From 5c601fe99efdda329ea0cc0f31a42852ab1d1448 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 10:24:41 -0300 Subject: [PATCH 01/27] Use HTTP instead of WebSocket for Ogmios --- src/Contract/Backend/Ogmios.purs | 4 +- src/Contract/Backend/Ogmios/Mempool.purs | 119 +- src/Internal/Contract/Monad.purs | 53 +- src/Internal/Contract/Provider.purs | 33 +- src/Internal/Contract/ProviderBackend.purs | 2 +- src/Internal/QueryM.purs | 824 +----------- src/Internal/QueryM/CurrentEpoch.purs | 18 +- src/Internal/QueryM/EraSummaries.purs | 15 +- src/Internal/QueryM/JsonRpc2.purs | 12 +- src/Internal/QueryM/Ogmios.purs | 66 +- src/Internal/QueryM/OgmiosHttp.purs | 1108 +++++++++++++++++ .../{ => OgmiosWebsocket}/Dispatcher.purs | 2 +- .../OgmiosWebsocket}/JsWebSocket.js | 0 .../OgmiosWebsocket}/JsWebSocket.purs | 2 +- .../QueryM/OgmiosWebsocket/Mempool.purs | 148 +++ .../QueryM/OgmiosWebsocket/Queries.purs | 82 ++ .../QueryM/OgmiosWebsocket/Types.purs | 559 +++++++++ src/Internal/QueryM/Pools.purs | 38 +- src/Internal/ServerConfig.purs | 2 +- src/Internal/Test/E2E/Feedback/Browser.purs | 2 +- src/Internal/Test/E2E/Feedback/Node.purs | 2 +- src/Internal/Test/E2E/Route.purs | 2 +- src/Internal/Test/E2E/Runner.purs | 2 +- test/Ogmios/Aeson.purs | 3 +- test/Ogmios/GenerateFixtures.purs | 21 +- test/QueryM/AffInterface.purs | 3 +- test/Testnet/Contract/OgmiosMempool.purs | 6 +- 27 files changed, 2164 insertions(+), 964 deletions(-) create mode 100644 src/Internal/QueryM/OgmiosHttp.purs rename src/Internal/QueryM/{ => OgmiosWebsocket}/Dispatcher.purs (98%) rename src/Internal/{ => QueryM/OgmiosWebsocket}/JsWebSocket.js (100%) rename src/Internal/{ => QueryM/OgmiosWebsocket}/JsWebSocket.purs (96%) create mode 100644 src/Internal/QueryM/OgmiosWebsocket/Mempool.purs create mode 100644 src/Internal/QueryM/OgmiosWebsocket/Queries.purs create mode 100644 src/Internal/QueryM/OgmiosWebsocket/Types.purs diff --git a/src/Contract/Backend/Ogmios.purs b/src/Contract/Backend/Ogmios.purs index c5b5af454e..d9effe0f5e 100644 --- a/src/Contract/Backend/Ogmios.purs +++ b/src/Contract/Backend/Ogmios.purs @@ -11,8 +11,8 @@ import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.TransactionHash (TransactionHash) import Contract.Monad (Contract) import Ctl.Internal.Contract.Monad (wrapQueryM) -import Ctl.Internal.QueryM (submitTxOgmios) as QueryM import Ctl.Internal.QueryM.Ogmios (SubmitTxR) +import Ctl.Internal.QueryM.OgmiosHttp (submitTxOgmios) as OgmiosHttp import Ctl.Internal.QueryM.Pools (getPoolParameters) as QueryM -- | **This function can only run with Ogmios backend** @@ -26,4 +26,4 @@ getPoolParameters = wrapQueryM <<< QueryM.getPoolParameters -- | Error returning variant submitTxE :: TransactionHash -> CborBytes -> Contract SubmitTxR -submitTxE txhash cbor = wrapQueryM $ QueryM.submitTxOgmios txhash cbor +submitTxE txhash cbor = wrapQueryM $ OgmiosHttp.submitTxOgmios txhash cbor diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index 95a0792033..b4c071e3ab 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -2,8 +2,7 @@ -- | These functions only work with Ogmios backend (not Blockfrost!). -- | https://ogmios.dev/mini-protocols/local-tx-monitor/ module Contract.Backend.Ogmios.Mempool - ( module Ogmios - , acquireMempoolSnapshot + ( acquireMempoolSnapshot , fetchMempoolTxs , mempoolSnapshotHasTx , mempoolSnapshotNextTx @@ -19,35 +18,49 @@ import Cardano.Types.Transaction (Transaction) import Cardano.Types.TransactionHash (TransactionHash) import Contract.Monad (Contract) import Control.Monad.Error.Class (liftMaybe, try) +import Control.Monad.Reader.Trans (asks) import Ctl.Internal.Contract.Monad (wrapQueryM) -import Ctl.Internal.QueryM - ( acquireMempoolSnapshot - , mempoolSnapshotHasTx - , mempoolSnapshotNextTx - , mempoolSnapshotSizeAndCapacity - , releaseMempool - ) as QueryM +import Ctl.Internal.Logging (Logger, mkLogger) +import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios - ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) + ( MempoolSizeAndCapacity , MempoolSnapshotAcquired , MempoolTransaction(MempoolTransaction) + , acquireMempoolSnapshotCall ) as Ogmios +import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (JsWebSocket) +import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool + ( mempoolSnapshotHasTxCall + , mempoolSnapshotNextTxCall + , mempoolSnapshotSizeAndCapacityCall + , releaseMempoolCall + ) +import Ctl.Internal.QueryM.OgmiosWebsocket.Types + ( ListenerSet + , OgmiosListeners + , listeners + , mkRequestAff + , underlyingWebSocket + ) import Data.Array as Array import Data.ByteArray (hexToByteArray) import Data.List (List(Cons)) import Data.Maybe (Maybe(Just, Nothing)) +import Data.Newtype (unwrap) +import Effect.Aff.Class (liftAff) import Effect.Exception (error) -- | Establish a connection with the Local TX Monitor. -- | Instantly accquires the current mempool snapshot, and will wait for the next -- | mempool snapshot if used again before using `releaseMempool`. acquireMempoolSnapshot :: Contract Ogmios.MempoolSnapshotAcquired -acquireMempoolSnapshot = wrapQueryM QueryM.acquireMempoolSnapshot +acquireMempoolSnapshot = wrapQueryM acquireMempoolSnapshotFetch -- | Check to see if a TxHash is present in the current mempool snapshot. mempoolSnapshotHasTx :: Ogmios.MempoolSnapshotAcquired -> TransactionHash -> Contract Boolean -mempoolSnapshotHasTx ms = wrapQueryM <<< QueryM.mempoolSnapshotHasTx ms +mempoolSnapshotHasTx ms = wrapQueryM <<< mempoolSnapshotHasTxFetch ms -- | Get the first received TX in the current mempool snapshot. This function can -- | be recursively called to traverse the finger-tree of the mempool data set. @@ -56,7 +69,7 @@ mempoolSnapshotNextTx :: Ogmios.MempoolSnapshotAcquired -> Contract (Maybe Transaction) mempoolSnapshotNextTx mempoolAcquired = do - mbTx <- wrapQueryM $ QueryM.mempoolSnapshotNextTx mempoolAcquired + mbTx <- wrapQueryM $ mempoolSnapshotNextTxFetch mempoolAcquired for mbTx \(Ogmios.MempoolTransaction { raw }) -> do byteArray <- liftMaybe (error "Failed to decode transaction") $ hexToByteArray raw @@ -69,12 +82,12 @@ mempoolSnapshotNextTx mempoolAcquired = do mempoolSnapshotSizeAndCapacity :: Ogmios.MempoolSnapshotAcquired -> Contract Ogmios.MempoolSizeAndCapacity mempoolSnapshotSizeAndCapacity = wrapQueryM <<< - QueryM.mempoolSnapshotSizeAndCapacity + mempoolSnapshotSizeAndCapacityFetch -- | Release the connection to the Local TX Monitor. releaseMempool :: Ogmios.MempoolSnapshotAcquired -> Contract Unit -releaseMempool = wrapQueryM <<< QueryM.releaseMempool +releaseMempool = wrapQueryM <<< releaseMempoolFetch -- | A bracket-style function for working with mempool snapshots - ensures -- | release in the presence of exceptions @@ -100,3 +113,79 @@ fetchMempoolTxs ms = Array.fromFoldable <$> go case nextTX of Just tx -> Cons tx <$> go Nothing -> pure mempty + +acquireMempoolSnapshotFetch + :: QueryM Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshotFetch = + mkOgmiosRequest + Ogmios.acquireMempoolSnapshotCall + _.acquireMempool + unit + +mempoolSnapshotHasTxFetch + :: Ogmios.MempoolSnapshotAcquired + -> TransactionHash + -> QueryM Boolean +mempoolSnapshotHasTxFetch ms txh = + unwrap <$> mkOgmiosRequest + (mempoolSnapshotHasTxCall ms) + _.mempoolHasTx + txh + +mempoolSnapshotSizeAndCapacityFetch + :: Ogmios.MempoolSnapshotAcquired + -> QueryM Ogmios.MempoolSizeAndCapacity +mempoolSnapshotSizeAndCapacityFetch ms = + mkOgmiosRequest + (mempoolSnapshotSizeAndCapacityCall ms) + _.mempoolSizeAndCapacity + unit + +releaseMempoolFetch + :: Ogmios.MempoolSnapshotAcquired + -> QueryM Unit +releaseMempoolFetch ms = + unit <$ mkOgmiosRequest + (releaseMempoolCall ms) + _.releaseMempool + unit + +mempoolSnapshotNextTxFetch + :: Ogmios.MempoolSnapshotAcquired + -> QueryM (Maybe Ogmios.MempoolTransaction) +mempoolSnapshotNextTxFetch ms = + unwrap <$> mkOgmiosRequest + (mempoolSnapshotNextTxCall ms) + _.mempoolNextTx + unit + +-- | Builds an Ogmios request action using `QueryM` +mkOgmiosRequest + :: forall (request :: Type) (response :: Type) + . JsonRpc2.JsonRpc2Call request response + -> (OgmiosListeners -> ListenerSet request response) + -> request + -> QueryM response +mkOgmiosRequest jsonRpc2Call getLs inp = do + listeners' <- asks $ listeners <<< _.ogmiosWs <<< _.runtime + websocket <- asks $ underlyingWebSocket <<< _.ogmiosWs <<< _.runtime + mkRequest listeners' websocket jsonRpc2Call getLs inp + +mkRequest + :: forall (request :: Type) (response :: Type) (listeners :: Type) + . listeners + -> JsWebSocket + -> JsonRpc2.JsonRpc2Call request response + -> (listeners -> ListenerSet request response) + -> request + -> QueryM response +mkRequest listeners' ws jsonRpc2Call getLs inp = do + logger <- getLogger + liftAff $ mkRequestAff listeners' ws logger jsonRpc2Call getLs inp + where + getLogger :: QueryM Logger + getLogger = do + logLevel <- asks $ _.config >>> _.logLevel + mbCustomLogger <- asks $ _.config >>> _.customLogger + pure $ mkLogger logLevel mbCustomLogger + diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index a337facb94..34185b3c18 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -54,18 +54,21 @@ import Ctl.Internal.Contract.ProviderBackend , getCtlBackend ) import Ctl.Internal.Helpers (filterMapWithKeyM, liftM, logWithLevel) -import Ctl.Internal.JsWebSocket (_wsClose, _wsFinalize) import Ctl.Internal.Logging (Logger, mkLogger, setupLogs) -import Ctl.Internal.QueryM - ( QueryEnv - , QueryM - , WebSocket - , getProtocolParametersAff - , getSystemStartAff +import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.JsonRpc2 (OgmiosDecodeError, pprintOgmiosDecodeError) +import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) +import Ctl.Internal.QueryM.OgmiosHttp + ( getProtocolParameters + , getSystemStartTime + ) +import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (_wsClose, _wsFinalize) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) +import Ctl.Internal.QueryM.OgmiosWebsocket.Types + ( WebSocket , mkOgmiosWebSocketAff , underlyingWebSocket ) -import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM @@ -290,10 +293,32 @@ getLedgerConstants -> ProviderBackend -> Aff LedgerConstants getLedgerConstants params = case _ of - CtlBackend { ogmios: { ws } } _ -> - { pparams: _, systemStart: _ } - <$> (unwrap <$> getProtocolParametersAff ws logger) - <*> getSystemStartAff ws logger + CtlBackend ctlBackend _ -> do + let + logParams = + { logLevel: params.logLevel + , customLogger: params.customLogger + , suppressLogs: true + } + pparams <- unwrap <$> + ( runQueryM logParams ctlBackend getProtocolParameters >>= + throwOnLeft + ) + systemStart <- unwrap <$> + ( runQueryM logParams ctlBackend getSystemStartTime >>= + throwOnLeft + ) + pure { pparams, systemStart } + + where + throwOnLeft + :: forall a + . Either OgmiosDecodeError a + -> Aff a + throwOnLeft = case _ of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right x -> pure x + BlockfrostBackend backend _ -> runBlockfrostServiceM blockfrostLogger backend $ { pparams: _, systemStart: _ } @@ -458,7 +483,8 @@ mkQueryEnv :: forall (rest :: Row Type). LogParams rest -> CtlBackend -> QueryEnv mkQueryEnv params ctlBackend = { config: - { kupoConfig: ctlBackend.kupoConfig + { ogmiosConfig: ctlBackend.ogmios.config + , kupoConfig: ctlBackend.kupoConfig , logLevel: params.logLevel , customLogger: params.customLogger , suppressLogs: params.suppressLogs @@ -480,3 +506,4 @@ filterLockedUtxos utxos = withTxRefsCache :: forall (a :: Type). ReaderT UsedTxOuts Aff a -> Contract a withTxRefsCache = Contract <<< withReaderT _.usedTxOuts + diff --git a/src/Internal/Contract/Provider.purs b/src/Internal/Contract/Provider.purs index 8afd5d0208..b5e85f6e30 100644 --- a/src/Internal/Contract/Provider.purs +++ b/src/Internal/Contract/Provider.purs @@ -16,9 +16,9 @@ import Ctl.Internal.Contract.LogParams (LogParams) import Ctl.Internal.Contract.ProviderBackend (BlockfrostBackend, CtlBackend) import Ctl.Internal.Helpers (logWithLevel) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM (evaluateTxOgmios, getChainTip, submitTxOgmios) as QueryM -import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) as QueryM -import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) as QueryM +import Ctl.Internal.QueryM (evaluateTxOgmios) as QueryM +import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) as OgmiosHttp +import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) as OgmiosHttp import Ctl.Internal.QueryM.Kupo ( getDatumByHash , getOutputAddressesByTxHash @@ -29,11 +29,15 @@ import Ctl.Internal.QueryM.Kupo , utxosAt ) as Kupo import Ctl.Internal.QueryM.Ogmios (SubmitTxR(SubmitFail, SubmitTxSuccess)) +import Ctl.Internal.QueryM.OgmiosHttp + ( getChainTip + , submitTxOgmios + ) as OgmiosHttp import Ctl.Internal.QueryM.Pools ( getPoolIds , getPubKeyHashDelegationsAndRewards , getValidatorHashDelegationsAndRewards - ) as QueryM + ) as OgmiosHttp import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM @@ -59,13 +63,13 @@ providerForCtlBackend runQueryM params backend = , doesTxExist: runQueryM' <<< map (map isJust) <<< Kupo.isTxConfirmed , getTxAuxiliaryData: runQueryM' <<< Kupo.getTxAuxiliaryData , utxosAt: runQueryM' <<< Kupo.utxosAt - , getChainTip: Right <$> runQueryM' QueryM.getChainTip - , getCurrentEpoch: unwrap <$> runQueryM' QueryM.getCurrentEpoch + , getChainTip: Right <$> runQueryM' OgmiosHttp.getChainTip + , getCurrentEpoch: unwrap <$> runQueryM' OgmiosHttp.getCurrentEpoch , submitTx: \tx -> runQueryM' do let txHash = Transaction.hash tx logDebug' $ "Pre-calculated tx hash: " <> show txHash let txCborBytes = encodeCbor tx - result <- QueryM.submitTxOgmios txHash txCborBytes + result <- OgmiosHttp.submitTxOgmios txHash txCborBytes pure $ case result of SubmitTxSuccess th -> do if th == txHash then Right th @@ -74,17 +78,18 @@ providerForCtlBackend runQueryM params backend = "Computed TransactionHash is not equal to the one returned by Ogmios, please report as bug!" ) SubmitFail err -> Left $ ClientOtherError $ show err - , evaluateTx: \tx additionalUtxos -> unwrap <$> runQueryM' do - let txBytes = encodeCbor tx - QueryM.evaluateTxOgmios txBytes (wrap additionalUtxos) - , getEraSummaries: Right <$> runQueryM' QueryM.getEraSummaries - , getPoolIds: Right <$> runQueryM' QueryM.getPoolIds + , evaluateTx: \tx additionalUtxos -> unwrap <$> + runQueryM' do + let txBytes = encodeCbor tx + QueryM.evaluateTxOgmios txBytes (wrap additionalUtxos) + , getEraSummaries: Right <$> runQueryM' OgmiosHttp.getEraSummaries + , getPoolIds: Right <$> runQueryM' OgmiosHttp.getPoolIds , getPubKeyHashDelegationsAndRewards: \_ pubKeyHash -> Right <$> runQueryM' - (QueryM.getPubKeyHashDelegationsAndRewards pubKeyHash) + (OgmiosHttp.getPubKeyHashDelegationsAndRewards pubKeyHash) , getValidatorHashDelegationsAndRewards: \_ validatorHash -> Right <$> runQueryM' - (QueryM.getValidatorHashDelegationsAndRewards $ wrap validatorHash) + (OgmiosHttp.getValidatorHashDelegationsAndRewards $ wrap validatorHash) } where diff --git a/src/Internal/Contract/ProviderBackend.purs b/src/Internal/Contract/ProviderBackend.purs index 08b1e546a6..13139b4550 100644 --- a/src/Internal/Contract/ProviderBackend.purs +++ b/src/Internal/Contract/ProviderBackend.purs @@ -15,7 +15,7 @@ module Ctl.Internal.Contract.ProviderBackend import Prelude -import Ctl.Internal.QueryM (OgmiosWebSocket) +import Ctl.Internal.QueryM.OgmiosWebsocket.Types (OgmiosWebSocket) import Ctl.Internal.ServerConfig (ServerConfig) import Data.Maybe (Maybe(Just, Nothing)) import Data.Time.Duration (Seconds(Seconds)) diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 03b7752b9a..2470fd7149 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -3,228 +3,51 @@ -- | Since WebSockets do not define a mechanism for linking request/response. -- | Or for verifying that the connection is live, those concerns are addressed here module Ctl.Internal.QueryM - ( module ExportDispatcher - , module ExportServerConfig - , ClusterSetup - , ListenerSet - , OgmiosListeners - , OgmiosWebSocket - , QueryConfig - , QueryM + ( QueryM , ParQueryM , QueryMT(QueryMT) - , QueryEnv - , QueryRuntime - , SubmitTxListenerSet - , WebSocket(WebSocket) - , acquireMempoolSnapshot - , acquireMempoolSnapshotAff , evaluateTxOgmios - , getChainTip - , getLogger - , getProtocolParametersAff - , getSystemStartAff , handleAffjaxResponse - , listeners - , postAeson - , mkListenerSet - , defaultMessageListener - , mempoolSnapshotHasTx - , mempoolSnapshotHasTxAff - , mempoolSnapshotNextTx - , mempoolSnapshotNextTxAff - , mempoolSnapshotSizeAndCapacity - , mempoolSnapshotSizeAndCapacityAff - , mkOgmiosRequest - , mkOgmiosRequestAff - , mkOgmiosWebSocketAff - , mkRequest - , mkRequestAff - , releaseMempool - , releaseMempoolAff - , scriptToAeson - , submitTxOgmios - , underlyingWebSocket ) where import Prelude -import Aeson - ( class DecodeAeson - , Aeson - , JsonDecodeError(TypeMismatch) - , decodeAeson - , encodeAeson - , parseJsonStringToAeson - , stringifyAeson - ) -import Affjax (Error, Response, defaultRequest) as Affjax -import Affjax.RequestBody as Affjax.RequestBody -import Affjax.RequestHeader as Affjax.RequestHeader -import Affjax.ResponseFormat as Affjax.ResponseFormat +import Aeson (class DecodeAeson, decodeAeson, parseJsonStringToAeson) +import Affjax (Error, Response) as Affjax import Affjax.StatusCode as Affjax.StatusCode import Cardano.Provider.Error ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) , ServiceError(ServiceOtherError) ) -import Cardano.Types (PlutusScript) import Cardano.Types.CborBytes (CborBytes) -import Cardano.Types.Chain as Chain -import Cardano.Types.PlutusScript as PlutusScript -import Cardano.Types.TransactionHash (TransactionHash) -import Cardano.Wallet.Key (PrivatePaymentKey, PrivateStakeKey) import Control.Alt (class Alt) import Control.Alternative (class Alternative) -import Control.Monad.Error.Class - ( class MonadError - , class MonadThrow - , liftEither - , throwError - ) +import Control.Monad.Error.Class (class MonadError, class MonadThrow) import Control.Monad.Logger.Class (class MonadLogger) import Control.Monad.Reader.Class (class MonadAsk, class MonadReader) import Control.Monad.Reader.Trans (ReaderT(ReaderT), asks) import Control.Monad.Rec.Class (class MonadRec) import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) -import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Helpers (logWithLevel) -import Ctl.Internal.JsWebSocket - ( JsWebSocket - , Url - , _mkWebSocket - , _onWsConnect - , _onWsError - , _onWsMessage - , _removeOnWsError - , _wsClose - , _wsFinalize - , _wsSend - ) -import Ctl.Internal.Logging (Logger, mkLogger) -import Ctl.Internal.QueryM.Dispatcher - ( DispatchError(JsonError) - , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests - , RequestBody - , WebsocketDispatch - , mkWebsocketDispatch - , newDispatcher - , newPendingRequests - ) -import Ctl.Internal.QueryM.Dispatcher - ( DispatchError(JsonError, FaultError, ListenerCancelled) - , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests - , RequestBody - , WebsocketDispatch - , dispatchErrorToError - , mkWebsocketDispatch - , newDispatcher - , newPendingRequests - ) as ExportDispatcher -import Ctl.Internal.QueryM.JsonRpc2 - ( OgmiosDecodeError - , decodeOgmios - , ogmiosDecodeErrorToError - ) -import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 -import Ctl.Internal.QueryM.Ogmios - ( AdditionalUtxoSet - , DelegationsAndRewardsR - , HasTxR - , MaybeMempoolTransaction - , OgmiosProtocolParameters - , OgmiosTxEvaluationR - , PoolParametersR - , ReleasedMempool - , StakePoolsQueryArgument - ) +import Ctl.Internal.Logging (mkLogger) +import Ctl.Internal.QueryM.Ogmios (AdditionalUtxoSet, OgmiosTxEvaluationR) import Ctl.Internal.QueryM.Ogmios as Ogmios -import Ctl.Internal.QueryM.UniqueId (ListenerId) -import Ctl.Internal.ServerConfig - ( Host - , ServerConfig - , defaultOgmiosWsConfig - , mkHttpUrl - , mkServerUrl - , mkWsUrl - ) as ExportServerConfig -import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) -import Ctl.Internal.Types.SystemStart (SystemStart) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) +import Ctl.Internal.QueryM.OgmiosWebsocket.Types + ( listeners + , mkRequestAff + , underlyingWebSocket + ) import Data.Bifunctor (lmap) -import Data.ByteArray (byteArrayToHex) -import Data.Either (Either(Left, Right), either, isRight) -import Data.Foldable (foldl) -import Data.HTTP.Method (Method(POST)) -import Data.Log.Level (LogLevel(Error, Debug)) -import Data.Log.Message (Message) -import Data.Map as Map -import Data.Maybe (Maybe(Just, Nothing), fromMaybe, maybe) -import Data.MediaType.Common (applicationJSON) +import Data.Either (Either(Left, Right)) +import Data.Maybe (fromMaybe) import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Traversable (for_, traverse_) -import Data.Tuple (fst) -import Data.Tuple.Nested (type (/\), (/\)) -import Effect (Effect) -import Effect.Aff - ( Aff - , Canceler(Canceler) - , ParAff - , delay - , launchAff_ - , makeAff - , runAff_ - ) +import Data.Tuple.Nested ((/\)) +import Effect.Aff (Aff, ParAff) import Effect.Aff.Class (class MonadAff, liftAff) -import Effect.Class (class MonadEffect, liftEffect) -import Effect.Exception (Error, error) -import Effect.Ref as Ref - --- | Cluster setup contains everything that is needed to run a `Contract` on --- | a local cluster: paramters to connect to the services and private keys --- | that are pre-funded with Ada on that cluster -type ClusterSetup = - { ogmiosConfig :: ServerConfig - , kupoConfig :: ServerConfig - , keys :: - { payment :: PrivatePaymentKey - , stake :: Maybe PrivateStakeKey - } - } - --- | `QueryConfig` contains a complete specification on how to initialize a --- | `QueryM` environment. --- | It includes: --- | - server parameters for all the services --- | - network ID --- | - logging level --- | - optional custom logger -type QueryConfig = - { kupoConfig :: ServerConfig - , logLevel :: LogLevel - , customLogger :: Maybe (LogLevel -> Message -> Aff Unit) - , suppressLogs :: Boolean - } - --- | Reusable part of `QueryRuntime` that can be shared between many `QueryM` --- | instances running in parallel. --- | --- | Includes: --- | - WebSocket connections -type QueryRuntime = - { ogmiosWs :: OgmiosWebSocket - } - --- | `QueryEnv` contains everything needed for `QueryM` to run. -type QueryEnv = - { config :: QueryConfig - , runtime :: QueryRuntime - } +import Effect.Class (class MonadEffect) +import Effect.Exception (Error) type QueryM = QueryMT Aff @@ -278,53 +101,10 @@ instance Parallel (QueryMT ParAff) (QueryMT Aff) where sequential :: QueryMT ParAff ~> QueryMT Aff sequential = wrap <<< sequential <<< unwrap -getProtocolParametersAff - :: OgmiosWebSocket - -> (LogLevel -> String -> Effect Unit) - -> Aff OgmiosProtocolParameters -getProtocolParametersAff ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger Ogmios.queryProtocolParametersCall - _.getProtocolParameters - unit - -getSystemStartAff - :: OgmiosWebSocket - -> (LogLevel -> String -> Effect Unit) - -> Aff SystemStart -getSystemStartAff ogmiosWs logger = - unwrap <$> mkOgmiosRequestAff ogmiosWs logger Ogmios.querySystemStartCall - _.systemStart - unit - --------------------------------------------------------------------------------- --- Ogmios Local State Query Protocol --------------------------------------------------------------------------------- - -getChainTip :: QueryM Chain.Tip -getChainTip = ogmiosChainTipToTip <$> mkOgmiosRequest Ogmios.queryChainTipCall - _.chainTip - unit - where - ogmiosChainTipToTip :: Ogmios.ChainTipQR -> Chain.Tip - ogmiosChainTipToTip = case _ of - Ogmios.CtChainOrigin _ -> Chain.TipAtGenesis - Ogmios.CtChainPoint { slot, id } -> Chain.Tip $ wrap - { slot, blockHeaderHash: wrap $ unwrap id } - -------------------------------------------------------------------------------- -- Ogmios Local Tx Submission Protocol -------------------------------------------------------------------------------- -submitTxOgmios :: TransactionHash -> CborBytes -> QueryM Ogmios.SubmitTxR -submitTxOgmios txHash tx = do - ws <- asks $ underlyingWebSocket <<< _.ogmiosWs <<< _.runtime - listeners' <- asks $ listeners <<< _.ogmiosWs <<< _.runtime - cfg <- asks _.config - liftAff $ mkRequestAff listeners' ws (mkLogger cfg.logLevel cfg.customLogger) - Ogmios.submitTxCall - _.submit - (txHash /\ tx) - evaluateTxOgmios :: CborBytes -> AdditionalUtxoSet -> QueryM OgmiosTxEvaluationR evaluateTxOgmios cbor additionalUtxos = do @@ -340,115 +120,6 @@ evaluateTxOgmios cbor additionalUtxos = do -- Ogmios Local Tx Monitor Protocol -------------------------------------------------------------------------------- -acquireMempoolSnapshotAff - :: OgmiosWebSocket -> Logger -> Aff Ogmios.MempoolSnapshotAcquired -acquireMempoolSnapshotAff ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger Ogmios.acquireMempoolSnapshotCall - _.acquireMempool - unit - -withMempoolSnapshot - :: OgmiosWebSocket - -> Logger - -> (Maybe Ogmios.MempoolSnapshotAcquired -> Aff Unit) - -> Effect Unit -withMempoolSnapshot ogmiosWs logger cont = - flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of - Left err -> do - logger Error $ - "Failed to acquire a mempool snapshot: Error: " <> show err - launchAff_ (cont Nothing) - Right mempoolSnapshot -> - launchAff_ (cont $ Just mempoolSnapshot) - -mempoolSnapshotHasTxAff - :: OgmiosWebSocket - -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> TransactionHash - -> Aff Boolean -mempoolSnapshotHasTxAff ogmiosWs logger ms txh = - unwrap <$> mkOgmiosRequestAff ogmiosWs logger - (Ogmios.mempoolSnapshotHasTxCall ms) - _.mempoolHasTx - txh - -mempoolSnapshotSizeAndCapacityAff - :: OgmiosWebSocket - -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> Aff Ogmios.MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityAff ogmiosWs logger ms = - mkOgmiosRequestAff ogmiosWs logger - (Ogmios.mempoolSnapshotSizeAndCapacityCall ms) - _.mempoolSizeAndCapacity -- todo: typo - unit - -releaseMempoolAff - :: OgmiosWebSocket - -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> Aff ReleasedMempool -releaseMempoolAff ogmiosWs logger ms = - mkOgmiosRequestAff ogmiosWs logger (Ogmios.releaseMempoolCall ms) - _.releaseMempool - unit - -mempoolSnapshotNextTxAff - :: OgmiosWebSocket - -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> Aff (Maybe Ogmios.MempoolTransaction) -mempoolSnapshotNextTxAff ogmiosWs logger ms = unwrap <$> - mkOgmiosRequestAff ogmiosWs logger (Ogmios.mempoolSnapshotNextTxCall ms) - _.mempoolNextTx - unit - -acquireMempoolSnapshot - :: QueryM Ogmios.MempoolSnapshotAcquired -acquireMempoolSnapshot = - mkOgmiosRequest - Ogmios.acquireMempoolSnapshotCall - _.acquireMempool - unit - -mempoolSnapshotHasTx - :: Ogmios.MempoolSnapshotAcquired - -> TransactionHash - -> QueryM Boolean -mempoolSnapshotHasTx ms txh = - unwrap <$> mkOgmiosRequest - (Ogmios.mempoolSnapshotHasTxCall ms) - _.mempoolHasTx - txh - -mempoolSnapshotSizeAndCapacity - :: Ogmios.MempoolSnapshotAcquired - -> QueryM Ogmios.MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacity ms = - mkOgmiosRequest - (Ogmios.mempoolSnapshotSizeAndCapacityCall ms) - _.mempoolSizeAndCapacity - unit - -releaseMempool - :: Ogmios.MempoolSnapshotAcquired - -> QueryM Unit -releaseMempool ms = - unit <$ mkOgmiosRequest - (Ogmios.releaseMempoolCall ms) - _.releaseMempool - unit - -mempoolSnapshotNextTx - :: Ogmios.MempoolSnapshotAcquired - -> QueryM (Maybe Ogmios.MempoolTransaction) -mempoolSnapshotNextTx ms = - unwrap <$> mkOgmiosRequest - (Ogmios.mempoolSnapshotNextTxCall ms) - _.mempoolNextTx - unit - -------------------------------------------------------------------------------- -- Affjax -------------------------------------------------------------------------------- @@ -473,462 +144,3 @@ handleAffjaxResponse body # lmap (ClientDecodeJsonError body) <<< (decodeAeson <=< parseJsonStringToAeson) --- We can't use Affjax's typical `post`, since there will be a mismatch between --- the media type header and the request body -postAeson :: Url -> Aeson -> Aff (Either Affjax.Error (Affjax.Response String)) -postAeson url body = Affjax.request $ Affjax.defaultRequest - { method = Left POST - , content = Just $ Affjax.RequestBody.String $ stringifyAeson body - , url = url - , responseFormat = Affjax.ResponseFormat.string - , headers = [ Affjax.RequestHeader.ContentType applicationJSON ] - } - --- It's easier to just write the encoder here than provide an `EncodeJson` --- instance (there are some brutal cyclical dependency issues trying to --- write an instance in the `Types.*` modules) -scriptToAeson :: PlutusScript -> Aeson -scriptToAeson = encodeAeson <<< byteArrayToHex <<< unwrap <<< - PlutusScript.getBytes - --------------------------------------------------------------------------------- --- Type-safe `WebSocket` --------------------------------------------------------------------------------- - --- don't export this constructor --- type-safe websocket which has automated req/res dispatch and websocket --- failure handling -data WebSocket listeners = WebSocket JsWebSocket listeners -type OgmiosWebSocket = WebSocket OgmiosListeners - --- getter -underlyingWebSocket :: forall (a :: Type). WebSocket a -> JsWebSocket -underlyingWebSocket (WebSocket ws _) = ws - --- getter -listeners :: forall (listeners :: Type). WebSocket listeners -> listeners -listeners (WebSocket _ ls) = ls - --------------------------------------------------------------------------------- --- OgmiosWebSocket Setup and PrimOps --------------------------------------------------------------------------------- - -type IsTxConfirmed = TransactionHash -> Aff Boolean - -mkOgmiosWebSocketAff - :: IsTxConfirmed - -> Logger - -> ServerConfig - -> Aff OgmiosWebSocket -mkOgmiosWebSocketAff isTxConfirmed logger serverConfig = do - lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed - makeAff $ mkServiceWebSocket lens (mkWsUrl serverConfig) - -mkServiceWebSocket - :: forall (listeners :: Type) - . MkServiceWebSocketLens listeners - -> Url - -> (Either Error (WebSocket listeners) -> Effect Unit) - -> Effect Canceler -mkServiceWebSocket lens url continue = do - ws <- _mkWebSocket (lens.logger Debug) url - let - messageDispatch :: WebsocketDispatch - messageDispatch = mkWebsocketDispatch lens.dispatcher - - -- We want to fail if the first connection attempt is not successful. - -- Otherwise, we start reconnecting indefinitely. - onFirstConnectionError :: String -> Effect Unit - onFirstConnectionError errMessage = do - _wsFinalize ws - _wsClose ws - lens.logger Error $ - "First connection to " <> lens.serviceName <> " WebSocket failed. " - <> "Terminating. Error: " - <> errMessage - continue $ Left $ error errMessage - firstConnectionErrorRef <- _onWsError ws onFirstConnectionError - hasConnectedOnceRef <- Ref.new false - _onWsConnect ws $ Ref.read hasConnectedOnceRef >>= case _ of - true -> do - lens.logger Debug $ - lens.serviceName <> - " WebSocket connection re-established, resending pending requests..." - lens.resendPendingRequests ws - false -> do - lens.logger Debug $ "Connection to " <> lens.serviceName <> " established" - Ref.write true hasConnectedOnceRef - _removeOnWsError ws firstConnectionErrorRef - _onWsMessage ws (lens.logger Debug) $ defaultMessageListener lens.logger - [ messageDispatch ] - void $ _onWsError ws \err -> do - lens.logger Debug $ - lens.serviceName <> " WebSocket error (" <> err <> - "). Reconnecting..." - continue $ Right (lens.typedWebSocket ws) - pure $ Canceler $ \err -> liftEffect do - _wsFinalize ws - _wsClose ws - continue $ Left $ err - --------------------------------------------------------------------------------- --- Resend pending `SubmitTx` requests --------------------------------------------------------------------------------- - --- | For each pending `SubmitTx` request, checks whether the transaction has --- | been added to the mempool or has been included in a block before retrying --- | the request. -resendPendingSubmitRequests - :: OgmiosWebSocket - -> IsTxConfirmed - -> Logger - -> (RequestBody -> Effect Unit) - -> Dispatcher - -> PendingSubmitTxRequests - -> Effect Unit -resendPendingSubmitRequests - ogmiosWs - isTxConfirmed - logger - sendRequest - dispatcher - pr = do - submitTxPendingRequests <- Ref.read pr - unless (Map.isEmpty submitTxPendingRequests) do - -- Acquiring a mempool snapshot should never fail and, - -- after ws reconnection, should be instantaneous. - withMempoolSnapshot ogmiosWs logger case _ of - Nothing -> - liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests - Just ms -> do - -- A delay of 5 sec for transactions to be processed by the node - -- and added to the mempool: - delay (wrap 5000.0) - let (pr' :: Array _) = Map.toUnfoldable submitTxPendingRequests - for_ pr' \(listenerId /\ requestBody /\ txHash) -> - handlePendingSubmitRequest ms listenerId requestBody txHash - where - log :: String -> Boolean -> TransactionHash -> Aff Unit - log label value txHash = - liftEffect $ logger Debug $ - label <> ": " <> show value <> " TransactionHash: " <> show txHash - - handlePendingSubmitRequest - :: Ogmios.MempoolSnapshotAcquired - -> ListenerId - -> RequestBody - -> TransactionHash - -> Aff Unit - handlePendingSubmitRequest ms listenerId requestBody txHash = do - -- Check if the transaction was added to the mempool: - txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash - log "Tx in the mempool" txInMempool txHash - retrySubmitTx <- - if txInMempool then pure false - else do - -- Check if the transaction was included in the block: - txConfirmed <- isTxConfirmed txHash - log "Tx confirmed" txConfirmed txHash - unless txConfirmed $ liftEffect do - sendRequest requestBody - pure (not txConfirmed) - -- Manually dispatch `SubmitTx` response if resending is not required: - unless retrySubmitTx $ liftEffect do - Ref.modify_ (Map.delete listenerId) pr - dispatchMap <- Ref.read dispatcher - Ref.modify_ (Map.delete listenerId) dispatcher - Map.lookup listenerId dispatchMap # - maybe (pure unit) (_ $ submitSuccessPartialResp) - where - submitSuccessPartialResp :: Aeson - submitSuccessPartialResp = - encodeAeson $ Ogmios.submitSuccessPartialResp txHash - --------------------------------------------------------------------------------- --- `MkServiceWebSocketLens` for ogmios --------------------------------------------------------------------------------- - -type MkServiceWebSocketLens (listeners :: Type) = - { serviceName :: String - , dispatcher :: Dispatcher - , logger :: Logger - , typedWebSocket :: JsWebSocket -> WebSocket listeners - , resendPendingRequests :: JsWebSocket -> Effect Unit - } - -mkOgmiosWebSocketLens - :: Logger - -> IsTxConfirmed - -> Effect (MkServiceWebSocketLens OgmiosListeners) -mkOgmiosWebSocketLens logger isTxConfirmed = do - dispatcher <- newDispatcher - pendingRequests <- newPendingRequests - pendingSubmitTxRequests <- newPendingRequests - pure $ - let - ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket - ogmiosWebSocket ws = WebSocket ws - { chainTip: - mkListenerSet dispatcher pendingRequests - , evaluate: - mkListenerSet dispatcher pendingRequests - , getProtocolParameters: - mkListenerSet dispatcher pendingRequests - , eraSummaries: - mkListenerSet dispatcher pendingRequests - , currentEpoch: - mkListenerSet dispatcher pendingRequests - , systemStart: - mkListenerSet dispatcher pendingRequests - , acquireMempool: - mkListenerSet dispatcher pendingRequests - , releaseMempool: - mkListenerSet dispatcher pendingRequests - , mempoolHasTx: - mkListenerSet dispatcher pendingRequests - , mempoolNextTx: - mkListenerSet dispatcher pendingRequests - , mempoolSizeAndCapacity: - mkListenerSet dispatcher pendingRequests - , submit: - mkSubmitTxListenerSet dispatcher pendingSubmitTxRequests - , stakePools: - mkListenerSet dispatcher pendingRequests - , delegationsAndRewards: - mkListenerSet dispatcher pendingRequests - } - - resendPendingRequests :: JsWebSocket -> Effect Unit - resendPendingRequests ws = do - let sendRequest = _wsSend ws (logger Debug) - Ref.read pendingRequests >>= traverse_ sendRequest - resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed - logger - sendRequest - dispatcher - pendingSubmitTxRequests - in - { serviceName: "ogmios" - , dispatcher - , logger - , typedWebSocket: ogmiosWebSocket - , resendPendingRequests - } - --------------------------------------------------------------------------------- --- ListenerSet --------------------------------------------------------------------------------- - -type OgmiosListeners = - { chainTip :: ListenerSet Unit Ogmios.ChainTipQR - , submit :: SubmitTxListenerSet - , evaluate :: - ListenerSet (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR - , getProtocolParameters :: ListenerSet Unit OgmiosProtocolParameters - , eraSummaries :: ListenerSet Unit Ogmios.OgmiosEraSummaries - , currentEpoch :: ListenerSet Unit Ogmios.CurrentEpoch - , systemStart :: ListenerSet Unit Ogmios.OgmiosSystemStart - , acquireMempool :: ListenerSet Unit Ogmios.MempoolSnapshotAcquired - , releaseMempool :: ListenerSet Unit ReleasedMempool - , mempoolHasTx :: ListenerSet TransactionHash HasTxR - , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction - , mempoolSizeAndCapacity :: ListenerSet Unit Ogmios.MempoolSizeAndCapacity - , stakePools :: ListenerSet StakePoolsQueryArgument PoolParametersR - , delegationsAndRewards :: ListenerSet (Array String) DelegationsAndRewardsR - } - --- convenience type for adding additional query types later -type ListenerSet (request :: Type) (response :: Type) = - { addMessageListener :: - ListenerId - -> (Either OgmiosDecodeError response -> Effect Unit) - -> Effect Unit - , removeMessageListener :: ListenerId -> Effect Unit - -- ^ Removes ID from dispatch map and pending requests queue. - , addRequest :: ListenerId -> RequestBody /\ request -> Effect Unit - -- ^ Saves request body until the request is fulfilled. The body is used - -- to replay requests in case of a WebSocket failure. - } - -type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) - Ogmios.SubmitTxR - -mkAddMessageListener - :: forall (response :: Type) - . JsonRpc2.DecodeOgmios response - => Dispatcher - -> ( ListenerId - -> (Either JsonRpc2.OgmiosDecodeError response -> Effect Unit) - -> Effect Unit - ) -mkAddMessageListener dispatcher = - \reflection handler -> - flip Ref.modify_ dispatcher $ - Map.insert reflection - (\aeson -> handler $ decodeOgmios aeson) - -mkRemoveMessageListener - :: forall (requestData :: Type) - . Dispatcher - -> GenericPendingRequests requestData - -> (ListenerId -> Effect Unit) -mkRemoveMessageListener dispatcher pendingRequests = - \reflection -> do - Ref.modify_ (Map.delete reflection) dispatcher - Ref.modify_ (Map.delete reflection) pendingRequests - --- we manipluate closures to make the DispatchIdMap updateable using these --- methods, this can be picked up by a query or cancellation function -mkListenerSet - :: forall (request :: Type) (response :: Type) - . JsonRpc2.DecodeOgmios response - => Dispatcher - -> PendingRequests - -> ListenerSet request response -mkListenerSet dispatcher pendingRequests = - { addMessageListener: - mkAddMessageListener dispatcher - , removeMessageListener: - mkRemoveMessageListener dispatcher pendingRequests - , addRequest: - \reflection (requestBody /\ _) -> - Ref.modify_ (Map.insert reflection requestBody) pendingRequests - } - -mkSubmitTxListenerSet - :: Dispatcher -> PendingSubmitTxRequests -> SubmitTxListenerSet -mkSubmitTxListenerSet dispatcher pendingRequests = - { addMessageListener: - mkAddMessageListener dispatcher - , removeMessageListener: - mkRemoveMessageListener dispatcher pendingRequests - , addRequest: - \reflection (requestBody /\ txHash /\ _) -> - Ref.modify_ (Map.insert reflection (requestBody /\ txHash)) - pendingRequests - } - --- | Builds an Ogmios request action using `QueryM` -mkOgmiosRequest - :: forall (request :: Type) (response :: Type) - . JsonRpc2.JsonRpc2Call request response - -> (OgmiosListeners -> ListenerSet request response) - -> request - -> QueryM response -mkOgmiosRequest jsonRpc2Call getLs inp = do - listeners' <- asks $ listeners <<< _.ogmiosWs <<< _.runtime - websocket <- asks $ underlyingWebSocket <<< _.ogmiosWs <<< _.runtime - mkRequest listeners' websocket jsonRpc2Call getLs inp - --- | Builds an Ogmios request action using `Aff` -mkOgmiosRequestAff - :: forall (request :: Type) (response :: Type) - . OgmiosWebSocket - -> Logger - -> JsonRpc2.JsonRpc2Call request response - -> (OgmiosListeners -> ListenerSet request response) - -> request - -> Aff response -mkOgmiosRequestAff ogmiosWs = mkRequestAff - (listeners ogmiosWs) - (underlyingWebSocket ogmiosWs) - -mkRequest - :: forall (request :: Type) (response :: Type) (listeners :: Type) - . listeners - -> JsWebSocket - -> JsonRpc2.JsonRpc2Call request response - -> (listeners -> ListenerSet request response) - -> request - -> QueryM response -mkRequest listeners' ws jsonRpc2Call getLs inp = do - logger <- getLogger - liftAff $ mkRequestAff listeners' ws logger jsonRpc2Call getLs inp - -getLogger :: QueryM Logger -getLogger = do - logLevel <- asks $ _.config >>> _.logLevel - mbCustomLogger <- asks $ _.config >>> _.customLogger - pure $ mkLogger logLevel mbCustomLogger - -mkRequestAff - :: forall (request :: Type) (response :: Type) (listeners :: Type) - . listeners - -> JsWebSocket - -> Logger - -> JsonRpc2.JsonRpc2Call request response - -> (listeners -> ListenerSet request response) - -> request - -> Aff response -mkRequestAff listeners' webSocket logger jsonRpc2Call getLs input = do - { body, id } <- - liftEffect $ JsonRpc2.buildRequest jsonRpc2Call input - let - respLs :: ListenerSet request response - respLs = getLs listeners' - - sBody :: RequestBody - sBody = stringifyAeson body - - affFunc :: (Either Error response -> Effect Unit) -> Effect Canceler - affFunc cont = do - _ <- respLs.addMessageListener id - ( \res -> do - respLs.removeMessageListener id - cont $ lmap ogmiosDecodeErrorToError res - ) - respLs.addRequest id (sBody /\ input) - _wsSend webSocket (logger Debug) sBody - -- Uncomment this code fragment to test `SubmitTx` request resend logic: - -- let method = aesonObject (flip getFieldOptional "methodname") body - -- when (method == Right (Just "SubmitTx")) do - -- _wsReconnect webSocket - pure $ Canceler $ \err -> do - liftEffect $ respLs.removeMessageListener id - liftEffect $ throwError $ err - makeAff affFunc - --- an empty error we can compare to, useful for ensuring we've not received any other kind of error -defaultErr :: JsonDecodeError -defaultErr = TypeMismatch "default error" - -defaultMessageListener - :: Logger - -> Array WebsocketDispatch - -> String - -> Effect Unit -defaultMessageListener logger dispatchArray msg = do - aeson <- liftEither $ lmap (const $ error "Unable to parse response") $ - parseJsonStringToAeson msg - -- here, we need to fold the input over the array of functions until we get - -- a success, then execute the effect. - -- using a fold instead of a traverse allows us to skip a bunch of execution - eAction :: Either DispatchError (Effect Unit) <- foldl - (messageFoldF aeson) - (pure $ Left $ JsonError defaultErr) - dispatchArray - either - -- we expect a lot of parse errors, some messages (could?) fall through completely - ( \err -> - unless - ( case err of - JsonError jsonErr -> jsonErr == defaultErr - _ -> false - ) - do - logger Error $ - "unexpected error on input: " <> msg - <> " Error:" - <> show err - ) - identity - eAction - -messageFoldF - :: Aeson - -> Effect (Either DispatchError (Effect Unit)) - -> (Aeson -> (Effect (Either DispatchError (Effect Unit)))) - -> Effect (Either DispatchError (Effect Unit)) -messageFoldF msg acc' func = do - acc <- acc' - if isRight acc then acc' else func msg diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index f023fb16fa..527c50b1ad 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -5,11 +5,19 @@ module Ctl.Internal.QueryM.CurrentEpoch import Prelude -import Ctl.Internal.QueryM (QueryM, mkOgmiosRequest) -import Ctl.Internal.QueryM.Ogmios (CurrentEpoch, queryCurrentEpochCall) as Ogmios +import Control.Monad.Error.Class (throwError) +import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) +import Ctl.Internal.QueryM.Ogmios (CurrentEpoch) +import Ctl.Internal.QueryM.OgmiosHttp (currentEpoch) as OgmiosHttp +import Data.Either (Either(Right, Left)) +import Effect.Exception (error) -- | Get the current Epoch. Details can be found https://ogmios.dev/api/ under -- | "currentEpoch" query -getCurrentEpoch :: QueryM Ogmios.CurrentEpoch -getCurrentEpoch = - mkOgmiosRequest Ogmios.queryCurrentEpochCall _.currentEpoch unit +getCurrentEpoch :: QueryM CurrentEpoch +getCurrentEpoch = do + resp <- OgmiosHttp.currentEpoch + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure val diff --git a/src/Internal/QueryM/EraSummaries.purs b/src/Internal/QueryM/EraSummaries.purs index 21e5dc88c6..f8ec010c5a 100644 --- a/src/Internal/QueryM/EraSummaries.purs +++ b/src/Internal/QueryM/EraSummaries.purs @@ -6,12 +6,19 @@ module Ctl.Internal.QueryM.EraSummaries import Prelude import Cardano.Types.EraSummaries (EraSummaries) -import Ctl.Internal.QueryM (QueryM, mkOgmiosRequest) -import Ctl.Internal.QueryM.Ogmios (queryEraSummariesCall) as Ogmios +import Control.Monad.Error.Class (throwError) +import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) +import Ctl.Internal.QueryM.OgmiosHttp (eraSummaries) as OgmiosHttp +import Data.Either (Either(Right, Left)) import Data.Newtype (unwrap) +import Effect.Exception (error) -- | Get `EraSummaries` as used for Slot arithemetic. Details can be found -- | https://ogmios.dev/api/ under "eraSummaries" query getEraSummaries :: QueryM EraSummaries -getEraSummaries = - unwrap <$> mkOgmiosRequest Ogmios.queryEraSummariesCall _.eraSummaries unit +getEraSummaries = do + resp <- OgmiosHttp.eraSummaries + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure $ unwrap $ val diff --git a/src/Internal/QueryM/JsonRpc2.purs b/src/Internal/QueryM/JsonRpc2.purs index de5454d8db..78603db09f 100644 --- a/src/Internal/QueryM/JsonRpc2.purs +++ b/src/Internal/QueryM/JsonRpc2.purs @@ -8,7 +8,12 @@ module Ctl.Internal.QueryM.JsonRpc2 , JsonRpc2Response , decodeResult , ogmiosDecodeErrorToError - , OgmiosDecodeError(ResultDecodingError, InvalidResponse, ErrorResponse) + , OgmiosDecodeError + ( ResultDecodingError + , ClientErrorResponse + , InvalidResponse + , ErrorResponse + ) , OgmiosError(OgmiosError) , class DecodeOgmios , decodeOgmios @@ -34,6 +39,7 @@ import Aeson , printJsonDecodeError , stringifyAeson ) +import Cardano.Provider.Error (ClientError, pprintClientError) import Ctl.Internal.QueryM.UniqueId (ListenerId, uniqueId) import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right)) @@ -147,6 +153,8 @@ data OgmiosDecodeError -- Server responded with error. = ErrorResponse (Maybe OgmiosError) -- Server responded with result, parsing of which failed + | ClientErrorResponse ClientError + -- Server responded with result, parsing of which failed | ResultDecodingError JsonDecodeError -- Received JsonRpc2Response was not of the right format. | InvalidResponse JsonDecodeError @@ -159,6 +167,8 @@ instance Show OgmiosDecodeError where pprintOgmiosDecodeError :: OgmiosDecodeError -> String pprintOgmiosDecodeError (ErrorResponse err) = "Ogmios responded with error: " <> maybe "" pprintOgmiosError err +pprintOgmiosDecodeError (ClientErrorResponse err) = + "Ogmios responded with error: " <> pprintClientError err pprintOgmiosDecodeError (ResultDecodingError err) = "Failed to parse the result: " <> printJsonDecodeError err pprintOgmiosDecodeError (InvalidResponse err) = diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index de3da772d9..30fd3dc127 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -24,24 +24,16 @@ module Ctl.Internal.QueryM.Ogmios , HasTxR(HasTxR) , MaybeMempoolTransaction(MaybeMempoolTransaction) , OgmiosTxEvaluationR(OgmiosTxEvaluationR) - , acquireMempoolSnapshotCall - , aesonArray , aesonObject + , aesonArray + , acquireMempoolSnapshotCall , evaluateTxCall - , queryStakePoolsCall , mempoolSnapshotHasTxCall , mempoolSnapshotNextTxCall , mempoolSnapshotSizeAndCapacityCall , mkOgmiosCallType , mkOgmiosCallTypeNoArgs - , queryChainTipCall - , queryCurrentEpochCall - , queryEraSummariesCall - , queryProtocolParametersCall - , querySystemStartCall - , queryDelegationsAndRewards , releaseMempoolCall - , submitTxCall , submitSuccessPartialResp , parseIpv6String , rationalToSubcoin @@ -193,65 +185,11 @@ import JS.BigInt as BigInt import Untagged.TypeCheck (class HasRuntimeType) import Untagged.Union (type (|+|), toEither1) --------------------------------------------------------------------------------- --- Local State Query Protocol --- https://ogmios.dev/mini-protocols/local-state-query/ --------------------------------------------------------------------------------- - --- | Queries Ogmios for the system start Datetime -querySystemStartCall :: JsonRpc2Call Unit OgmiosSystemStart -querySystemStartCall = mkOgmiosCallTypeNoArgs "queryNetwork/startTime" - --- | Queries Ogmios for the current epoch -queryCurrentEpochCall :: JsonRpc2Call Unit CurrentEpoch -queryCurrentEpochCall = mkOgmiosCallTypeNoArgs "queryLedgerState/epoch" - --- | Queries Ogmios for an array of era summaries, used for Slot arithmetic. -queryEraSummariesCall :: JsonRpc2Call Unit OgmiosEraSummaries -queryEraSummariesCall = mkOgmiosCallTypeNoArgs "queryLedgerState/eraSummaries" - --- | Queries Ogmios for the current protocol parameters -queryProtocolParametersCall :: JsonRpc2Call Unit OgmiosProtocolParameters -queryProtocolParametersCall = mkOgmiosCallTypeNoArgs - "queryLedgerState/protocolParameters" - --- | Queries Ogmios for the chain’s current tip. -queryChainTipCall :: JsonRpc2Call Unit ChainTipQR -queryChainTipCall = mkOgmiosCallTypeNoArgs "queryNetwork/tip" - --- | Queries Ogmios for pool parameters of all pools or of the provided pools. -queryStakePoolsCall :: JsonRpc2Call StakePoolsQueryArgument PoolParametersR -queryStakePoolsCall = mkOgmiosCallType - { method: "queryLedgerState/stakePools" - , params: identity - } - -queryDelegationsAndRewards - :: JsonRpc2Call (Array String) DelegationsAndRewardsR -- todo: whats string? git blame line below to restore -queryDelegationsAndRewards = mkOgmiosCallType - { method: "queryLedgerState/rewardAccountSummaries" - , params: \skhs -> - { query: - { delegationsAndRewards: skhs - } - } - } - -------------------------------------------------------------------------------- -- Local Tx Submission Protocol -- https://ogmios.dev/mini-protocols/local-tx-submission/ -------------------------------------------------------------------------------- --- | Sends a serialized signed transaction with its full witness through the --- | Cardano network via Ogmios. -submitTxCall :: JsonRpc2Call (TransactionHash /\ CborBytes) SubmitTxR -submitTxCall = mkOgmiosCallType - { method: "submitTransaction" - , params: \(_ /\ cbor) -> - { transaction: { cbor: byteArrayToHex $ unwrap cbor } - } - } - -- | Evaluates the execution units of scripts present in a given transaction, -- | without actually submitting the transaction. evaluateTxCall diff --git a/src/Internal/QueryM/OgmiosHttp.purs b/src/Internal/QueryM/OgmiosHttp.purs new file mode 100644 index 0000000000..ecdb67f70a --- /dev/null +++ b/src/Internal/QueryM/OgmiosHttp.purs @@ -0,0 +1,1108 @@ +module Ctl.Internal.QueryM.OgmiosHttp + ( getSystemStartTime + , aesonObject + , getChainTip + , currentEpoch + , submitTxOgmios + , poolParameters + , StakePoolsQueryArgument(StakePoolsQueryArgument) + , delegationsAndRewards + , eraSummaries + , getProtocolParameters + -- , evaluateTxOgmios + ) where + +import Prelude + +import Aeson + ( class DecodeAeson + , class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch, MissingValue, AtKey) + , caseAesonArray + , caseAesonObject + , caseAesonString + , decodeAeson + , encodeAeson + , fromArray + , getField + , isNull + , parseJsonStringToAeson + , stringifyAeson + , (.:?) + ) +import Aeson as Aeson +import Affjax (Error, Response, defaultRequest) as Affjax +import Affjax.RequestBody as Affjax.RequestBody +import Affjax.RequestHeader as Affjax.RequestHeader +import Affjax.ResponseFormat (string) as Affjax.ResponseFormat +import Affjax.StatusCode (StatusCode(StatusCode)) +import Affjax.StatusCode as Affjax.StatusCode +import Cardano.AsCbor (encodeCbor) +import Cardano.Provider.Error (ClientError(..), ServiceError(..)) +import Cardano.Provider.TxEvaluation as Provider +import Cardano.Serialization.Lib (fromBytes) +import Cardano.Types + ( Bech32String + , BigNum(BigNum) + , Language(PlutusV3, PlutusV2, PlutusV1) + , RedeemerTag + ) +import Cardano.Types.AssetName (unAssetName) +import Cardano.Types.BigNum (BigNum) +import Cardano.Types.BigNum (fromBigInt) as BigNum +import Cardano.Types.CborBytes (CborBytes) +import Cardano.Types.Chain as Chain +import Cardano.Types.Coin (Coin(Coin)) +import Cardano.Types.CostModel (CostModel(CostModel)) +import Cardano.Types.EraSummaries + ( EraSummaries(..) + , EraSummary(..) + , EraSummaryParameters(..) + , EraSummaryTime(..) + ) +import Cardano.Types.ExUnitPrices (ExUnitPrices(ExUnitPrices)) +import Cardano.Types.ExUnits (ExUnits(ExUnits)) +import Cardano.Types.Int as Cardano +import Cardano.Types.NativeScript + ( NativeScript + ( ScriptPubkey + , ScriptAll + , ScriptAny + , ScriptNOfK + , TimelockStart + , TimelockExpiry + ) + ) +import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) +import Cardano.Types.PoolPubKeyHash (PoolPubKeyHash) +import Cardano.Types.RedeemerTag + ( RedeemerTag(Spend, Mint, Cert, Reward, Vote, Propose) + ) as RedeemerTag +import Cardano.Types.ScriptHash (ScriptHash) +import Cardano.Types.ScriptRef (ScriptRef(NativeScriptRef, PlutusScriptRef)) +import Cardano.Types.Slot (Slot(Slot)) +import Cardano.Types.TransactionHash (TransactionHash) +import Cardano.Types.UnitInterval (UnitInterval(UnitInterval)) +import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) +import Contract.Log (logTrace') +import Control.Monad.Error.Class (class MonadThrow, throwError) +import Control.Monad.Reader.Class (asks) +import Ctl.Internal.Affjax (request) as Affjax +import Ctl.Internal.Helpers (encodeMap, showWithParens) +import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.JsonRpc2 + ( class DecodeOgmios + , OgmiosDecodeError(..) + , OgmiosError + , decodeErrorOrResult + , decodeOgmios + , decodeResult + , pprintOgmiosDecodeError + ) +import Ctl.Internal.QueryM.Ogmios + ( CurrentEpoch + , DelegationsAndRewardsR(DelegationsAndRewardsR) + , OgmiosEraSummaries + , OgmiosProtocolParameters + , OgmiosSystemStart + , PoolParametersR + , SubmitTxR + ) as Ogmios +import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) +import Ctl.Internal.Types.ProtocolParameters + ( ProtocolParameters(ProtocolParameters) + ) +import Ctl.Internal.Types.Rational (Rational, (%)) +import Ctl.Internal.Types.Rational as Rational +import Ctl.Internal.Types.SystemStart + ( SystemStart + , sysStartFromOgmiosTimestamp + , sysStartToOgmiosTimestamp + ) +import Data.Array (catMaybes) +import Data.Array (fromFoldable) as Array +import Data.Bifunctor (lmap) +import Data.ByteArray (byteArrayToHex, hexToByteArray) +import Data.Either (Either(Left, Right), either, note) +import Data.Foldable (foldl) +import Data.Generic.Rep (class Generic) +import Data.HTTP.Method (Method(POST)) +import Data.Lens (_Right, to, (^?)) +import Data.List (List) +import Data.List as List +import Data.Map (Map) +import Data.Map as Map +import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe) +import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Show.Generic (genericShow) +import Data.String (Pattern(Pattern)) +import Data.String.Common (split) as String +import Data.Time.Duration (Milliseconds(Milliseconds)) +import Data.Traversable (for, traverse) +import Data.Tuple (Tuple(Tuple)) +import Data.Tuple.Nested (type (/\), (/\)) +import Data.UInt (UInt) +import Effect.Aff (Aff, delay) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Exception (Error, error) +import Foreign.Object (Object) +import Foreign.Object as Object +import JS.BigInt as BigInt +import Untagged.TypeCheck (class HasRuntimeType) +import Untagged.Union (type (|+|), toEither1) + +eraSummaries :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosEraSummaries) +eraSummaries = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "eraSummaries" + , method: "queryLedgerState/eraSummaries" + } + ) + +getSystemStartTime :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosSystemStart) +getSystemStartTime = do + let + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "getSystemStartTime" + , method: "queryNetwork/startTime" + } + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body + +getProtocolParameters + :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosProtocolParameters) +getProtocolParameters = do + let + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "getProtocolParameters" + , method: "queryLedgerState/protocolParameters" + } + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body + +getChainTip :: QueryM Chain.Tip +getChainTip = do + ogmiosChainTipToTip <$> ogmiosErrorHandler chainTip + where + ogmiosChainTipToTip :: ChainTipQR -> Chain.Tip + ogmiosChainTipToTip = case _ of + CtChainOrigin _ -> Chain.TipAtGenesis + CtChainPoint { slot, id } -> Chain.Tip $ wrap + { slot, blockHeaderHash: wrap $ unwrap id } + + chainTip :: QueryM (Either OgmiosDecodeError ChainTipQR) + chainTip = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "getChainTip" + , method: "queryNetwork/tip" + } + ) + +currentEpoch :: QueryM (Either OgmiosDecodeError Ogmios.CurrentEpoch) +currentEpoch = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "currentEpoch" + , method: "queryLedgerState/epoch" + } + ) + +submitTxOgmios :: TransactionHash -> CborBytes -> QueryM Ogmios.SubmitTxR +submitTxOgmios txHash tx = ogmiosErrorHandlerWithArg submitTx + (txHash /\ tx) + where + submitTx + :: TransactionHash /\ CborBytes + -> QueryM (Either OgmiosDecodeError Ogmios.SubmitTxR) + submitTx (_ /\ cbor) = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "submitTxOgmios" + , method: "submitTransaction" + , params: + { transaction: + { cbor: byteArrayToHex (unwrap cbor) + } + } + } + ) + +poolParameters + :: StakePoolsQueryArgument + -> QueryM (Either OgmiosDecodeError Ogmios.PoolParametersR) +poolParameters stakePools = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "poolParameters" + , method: "queryLedgerState/stakePools" + , params: stakePools + } + ) + +delegationsAndRewards + :: Array String -- ^ A list of reward account bech32 strings + -> QueryM (Either OgmiosDecodeError Ogmios.DelegationsAndRewardsR) +delegationsAndRewards rewardAccounts = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "delegationsAndRewards" + , method: "queryLedgerState/rewardAccountSummaries" + , params: + { query: + { delegationsAndRewards: rewardAccounts } + } + } + ) + +-- evaluateTxOgmios +-- :: CborBytes -> AdditionalUtxoSet -> QueryM Provider.TxEvaluationR +-- evaluateTxOgmios cbor additionalUtxos = ogmiosErrorHandlerWithArg +-- evaluateTx +-- (cbor /\ additionalUtxos) +-- where +-- evaluateTx +-- :: CborBytes /\ AdditionalUtxoSet +-- -> Aff (Either OgmiosDecodeError Provider.TxEvaluationR) +-- evaluateTx (cbor /\ utxoqr) = do +-- handleAffjaxOgmiosResponse <$> +-- ( ogmiosPostRequest +-- $ Aeson.encodeAeson +-- { jsonrpc: "2.0" +-- , id: "evaluateTxOgmios" +-- , method: "evaluateTransaction" +-- , params: +-- { transaction: { cbor: byteArrayToHex $ unwrap cbor } +-- , additionalUtxo: utxoqr +-- } +-- } +-- ) + +instance DecodeOgmios TxEvaluationR where + decodeOgmios = decodeErrorOrResult + { parseError: map (wrap <<< Left) <<< decodeAeson } + { parseResult: map (wrap <<< Right) <<< decodeAeson } + +-- Response parsing +-------------------------------------------------------------------------------- + +type OgmiosAddress = Bech32String + +-------------------------------------------------------------------------------- +-- Local Tx Monitor Query Response & Parsing +-------------------------------------------------------------------------------- + +newtype HasTxR = HasTxR Boolean + +derive instance Newtype HasTxR _ + +instance DecodeOgmios HasTxR where + decodeOgmios = decodeResult (map HasTxR <<< decodeAeson) + +---------------- TX SUBMISSION QUERY RESPONSE & PARSING + +data SubmitTxR + = SubmitTxSuccess TransactionHash + | SubmitFail OgmiosError + +derive instance Generic SubmitTxR _ + +instance Show SubmitTxR where + show = genericShow + +instance DecodeOgmios SubmitTxR where + decodeOgmios = decodeErrorOrResult + { parseError: decodeError } + { parseResult: map SubmitTxSuccess <<< decodeTxHash } + + where + + decodeError aeson = map SubmitFail do + -- With Ogmios 5.6 we failed with error on deserialization error, so we do now as well + err :: OgmiosError <- decodeAeson aeson + let code = (unwrap err).code + -- as of 7.11.23 it's in {3005} u [3100, 3159] range + if (3000 <= code && code <= 3999) then + pure err + else + Left $ TypeMismatch + "Expected error code in a range [3000, 3999]" + + decodeTxHash :: Aeson -> Either JsonDecodeError TransactionHash + decodeTxHash = aesonObject \o -> do + txHashHex <- getField o "transaction" >>= flip getField "id" + note (TypeMismatch "Expected hexstring of TransactionHash") $ + hexToByteArray txHashHex >>= fromBytes >>> map wrap + +---------------- SYSTEM START QUERY RESPONSE & PARSING +newtype OgmiosSystemStart = OgmiosSystemStart SystemStart + +derive instance Generic OgmiosSystemStart _ +derive instance Newtype OgmiosSystemStart _ +derive newtype instance Eq OgmiosSystemStart + +instance Show OgmiosSystemStart where + show = genericShow + +instance DecodeAeson OgmiosSystemStart where + decodeAeson = + caseAesonString (Left (TypeMismatch "Timestamp string")) + (map wrap <<< lmap TypeMismatch <<< sysStartFromOgmiosTimestamp) + +instance EncodeAeson OgmiosSystemStart where + encodeAeson = encodeAeson <<< sysStartToOgmiosTimestamp <<< unwrap + +instance DecodeOgmios OgmiosSystemStart where + decodeOgmios = decodeResult decodeAeson + +---------------- CURRENT EPOCH QUERY RESPONSE & PARSING +newtype CurrentEpoch = CurrentEpoch BigNum + +derive instance Generic CurrentEpoch _ +derive instance Newtype CurrentEpoch _ +derive newtype instance DecodeAeson CurrentEpoch +derive newtype instance EncodeAeson CurrentEpoch +derive newtype instance Eq CurrentEpoch +derive newtype instance Ord CurrentEpoch + +instance Show CurrentEpoch where + show (CurrentEpoch ce) = showWithParens "CurrentEpoch" ce + +instance DecodeOgmios CurrentEpoch where + decodeOgmios = decodeResult decodeAeson + +---------------- ERA SUMMARY QUERY RESPONSE & PARSING + +newtype OgmiosEraSummaries = OgmiosEraSummaries EraSummaries + +derive instance Generic OgmiosEraSummaries _ +derive instance Newtype OgmiosEraSummaries _ +derive newtype instance Eq OgmiosEraSummaries + +instance Show OgmiosEraSummaries where + show = genericShow + +instance DecodeAeson OgmiosEraSummaries where + -- There is some differences between ogmios 6.0 spec and actual results + -- in "start" "end" fields and "slotLength". + decodeAeson = aesonArray (map (wrap <<< wrap) <<< traverse decodeEraSummary) + where + decodeEraSummaryTime :: Aeson -> Either JsonDecodeError EraSummaryTime + decodeEraSummaryTime = aesonObject \obj -> do + time <- flip getField "seconds" =<< getField obj "time" + slot <- getField obj "slot" + epoch <- getField obj "epoch" + pure $ wrap { time, slot, epoch } + + decodeEraSummary :: Aeson -> Either JsonDecodeError EraSummary + decodeEraSummary = aesonObject \o -> do + start <- decodeEraSummaryTime =<< getField o "start" + -- The field "end" is required by Ogmios API, but it can optionally return + -- Null, so we want to fail if the field is absent but make Null value + -- acceptable in presence of the field (hence why "end" is wrapped in + -- `Maybe`). + end' <- getField o "end" + end <- + if isNull end' then pure Nothing else Just <$> decodeEraSummaryTime end' + parameters <- decodeEraSummaryParameters =<< getField o "parameters" + pure $ wrap { start, end, parameters } + + decodeEraSummaryParameters + :: Object Aeson -> Either JsonDecodeError EraSummaryParameters + decodeEraSummaryParameters o = do + epochLength <- getField o "epochLength" + slotLength <- flip getField "milliseconds" =<< getField o "slotLength" + safeZone <- fromMaybe zero <$> getField o "safeZone" + pure $ wrap { epochLength, slotLength, safeZone } + +instance EncodeAeson OgmiosEraSummaries where + encodeAeson (OgmiosEraSummaries (EraSummaries es)) = + fromArray $ map encodeEraSummary es + where + encodeEraSummaryTime :: EraSummaryTime -> Aeson + encodeEraSummaryTime (EraSummaryTime { time, slot, epoch }) = + encodeAeson { "time": { "seconds": time }, "slot": slot, "epoch": epoch } + + encodeEraSummary :: EraSummary -> Aeson + encodeEraSummary (EraSummary { start, end, parameters }) = + encodeAeson + { "start": encodeEraSummaryTime start + , "end": encodeEraSummaryTime <$> end + , "parameters": encodeEraSummaryParameters parameters + } + + encodeEraSummaryParameters :: EraSummaryParameters -> Aeson + encodeEraSummaryParameters (EraSummaryParameters params) = + encodeAeson + { "epochLength": params.epochLength + , "slotLength": { "milliseconds": params.slotLength } + , "safeZone": params.safeZone + } + +instance DecodeOgmios OgmiosEraSummaries where + decodeOgmios = decodeResult decodeAeson + +---------------- DELEGATIONS & REWARDS QUERY RESPONSE & PARSING + +newtype DelegationsAndRewardsR = DelegationsAndRewardsR + ( Map String + { rewards :: Maybe Coin + , delegate :: Maybe PoolPubKeyHash + } + ) + +derive instance Generic DelegationsAndRewardsR _ +derive instance Newtype DelegationsAndRewardsR _ + +instance DecodeAeson DelegationsAndRewardsR where + decodeAeson aeson = do + obj :: Object (Object Aeson) <- decodeAeson aeson + kvs <- for (Object.toUnfoldable obj :: Array _) \(Tuple k objParams) -> do + rewards <- map Coin <$> objParams .:? "rewards" + delegate <- objParams .:? "delegate" + pure $ k /\ { rewards, delegate } + pure $ DelegationsAndRewardsR $ Map.fromFoldable kvs + +instance DecodeOgmios DelegationsAndRewardsR where + decodeOgmios = decodeResult decodeAeson + +---------------- POOL PARAMETERS REQUEST & PARSING + +-- Nothing queries all pools, otherwise query selected pools. +newtype StakePoolsQueryArgument = StakePoolsQueryArgument + (Maybe (Array PoolPubKeyHash)) + +derive instance Newtype StakePoolsQueryArgument _ + +instance EncodeAeson StakePoolsQueryArgument where + encodeAeson a = do + maybe + (encodeAeson {}) + ( \poolPkhs -> encodeAeson + { stakePools: map (\pool -> { id: pool }) poolPkhs } + ) + (unwrap a) + +---------------- TX EVALUATION QUERY RESPONSE & PARSING + +type RedeemerPointer = { redeemerTag :: RedeemerTag, redeemerIndex :: UInt } + +type ExecutionUnits = { memory :: BigNum, steps :: BigNum } + +type OgmiosRedeemerPtr = { index :: UInt, purpose :: String } + +newtype TxEvaluationR = TxEvaluationR + (Either TxEvaluationFailure TxEvaluationResult) + +derive instance Newtype TxEvaluationR _ +derive instance Generic TxEvaluationR _ + +instance Show TxEvaluationR where + show = genericShow + +newtype TxEvaluationResult = TxEvaluationResult + (Map RedeemerPointer ExecutionUnits) + +derive instance Newtype TxEvaluationResult _ +derive instance Generic TxEvaluationResult _ + +instance Show TxEvaluationResult where + show = genericShow + +instance DecodeAeson TxEvaluationResult where + decodeAeson = aesonArray $ \array -> do + TxEvaluationResult <<< Map.fromFoldable <$> + traverse decodeRdmrPtrExUnitsItem array + + where + decodeRdmrPtrExUnitsItem + :: Aeson -> Either JsonDecodeError (RedeemerPointer /\ ExecutionUnits) + decodeRdmrPtrExUnitsItem elem = do + res + :: { validator :: OgmiosRedeemerPtr + , budget :: { memory :: BigNum, cpu :: BigNum } + } <- decodeAeson elem + redeemerPtr <- decodeRedeemerPointer res.validator + pure $ redeemerPtr /\ { memory: res.budget.memory, steps: res.budget.cpu } + +redeemerTypeMismatch :: JsonDecodeError +redeemerTypeMismatch = TypeMismatch + "Expected redeemer to be one of: \ + \(spend|mint|publish|withdraw|vote|propose)" + +decodeRedeemerPointer + :: { index :: UInt, purpose :: String } + -> Either JsonDecodeError RedeemerPointer +decodeRedeemerPointer { index: redeemerIndex, purpose } = + note redeemerTypeMismatch $ { redeemerTag: _, redeemerIndex } <$> + redeemerTagFromString purpose + +redeemerTagFromString :: String -> Maybe RedeemerTag +redeemerTagFromString = case _ of + "spend" -> Just RedeemerTag.Spend + "mint" -> Just RedeemerTag.Mint + "publish" -> Just RedeemerTag.Cert + "withdraw" -> Just RedeemerTag.Reward + "vote" -> Just RedeemerTag.Vote + "propose" -> Just RedeemerTag.Propose + _ -> Nothing + +type OgmiosDatum = String +type OgmiosScript = String +type OgmiosTxId = String +type OgmiosTxIn = { txId :: OgmiosTxId, index :: Prim.Int } + +-- | Reason a script failed. +-- +-- The type definition is a least common denominator between Ogmios v6 format used by ogmios backend +-- and ogmios v5.6 format used by blockfrost backend +data ScriptFailure + = ExtraRedeemers (Array RedeemerPointer) + | MissingRequiredDatums + { missing :: (Array OgmiosDatum) + , provided :: Maybe (Array OgmiosDatum) + } + | MissingRequiredScripts + { missing :: Array RedeemerPointer + , resolved :: Maybe (Map RedeemerPointer ScriptHash) + } + | ValidatorFailed { error :: String, traces :: Array String } + | UnknownInputReferencedByRedeemer (Array OgmiosTxIn) + | NonScriptInputReferencedByRedeemer OgmiosTxIn + | NoCostModelForLanguage (Array String) + | InternalLedgerTypeConversionError String + | IllFormedExecutionBudget (Maybe ExecutionUnits) + +derive instance Generic ScriptFailure _ + +instance Show ScriptFailure where + show = genericShow + +-- The following cases are fine to fall through into unparsed error: +-- IncompatibleEra +-- NotEnoughSynced +-- CannotCreateEvaluationContext +data TxEvaluationFailure + = UnparsedError String + | AdditionalUtxoOverlap (Array OgmiosTxOutRef) + | ScriptFailures (Map RedeemerPointer (Array ScriptFailure)) + +derive instance Generic TxEvaluationFailure _ + +instance Show TxEvaluationFailure where + show = genericShow + +instance DecodeAeson ScriptFailure where + decodeAeson aeson = do + err :: OgmiosError <- decodeAeson aeson + let error = unwrap err + errorData <- maybe (Left (AtKey "data" MissingValue)) pure error.data + case error.code of + 3011 -> do + res :: { missingScripts :: Array OgmiosRedeemerPtr } <- decodeAeson + errorData + missing <- traverse decodeRedeemerPointer res.missingScripts + pure $ MissingRequiredScripts { missing: missing, resolved: Nothing } + 3012 -> do + res :: { validationError :: String, traces :: Array String } <- + decodeAeson errorData + pure $ ValidatorFailed + { error: res.validationError, traces: res.traces } + 3013 -> do + res + :: { unsuitableOutputReference :: + { transaction :: { id :: String }, index :: Prim.Int } + } <- decodeAeson errorData + pure $ NonScriptInputReferencedByRedeemer + { index: res.unsuitableOutputReference.index + , txId: res.unsuitableOutputReference.transaction.id + } + 3110 -> do + res :: { extraneousRedeemers :: Array OgmiosRedeemerPtr } <- decodeAeson + errorData + ExtraRedeemers <$> traverse decodeRedeemerPointer + res.extraneousRedeemers + 3111 -> do + res :: { missingDatums :: Array String } <- decodeAeson errorData + pure $ MissingRequiredDatums + { missing: res.missingDatums, provided: Nothing } + 3117 -> do + res + :: { unknownOutputReferences :: + Array { transaction :: { id :: String }, index :: Prim.Int } + } <- decodeAeson errorData + pure $ UnknownInputReferencedByRedeemer $ + map (\x -> { index: x.index, txId: x.transaction.id }) + res.unknownOutputReferences + 3115 -> do + res :: { missingCostModels :: Array String } <- decodeAeson errorData + pure $ NoCostModelForLanguage res.missingCostModels + -- this would actually fail at decoding error.data but it's good + 3999 -> pure $ InternalLedgerTypeConversionError error.message + _ -> Left $ TypeMismatch $ "Unknown ogmios error code: " <> show + error.code + +instance DecodeAeson TxEvaluationFailure where + decodeAeson aeson = do + error :: OgmiosError <- decodeAeson aeson + let code = (unwrap error).code + errorData <- maybe (Left (AtKey "data" MissingValue)) pure + (unwrap error).data + case code of + -- ScriptExecutionFailure + 3010 -> flip aesonArray errorData $ + ( \array -> + ( ScriptFailures <<< map Array.fromFoldable <<< collectIntoMap <$> + traverse parseElem array + ) + ) + -- Overlapping AdditionalUtxo + 3002 -> do + res + :: { overlappingOutputReferences :: + Array { transaction :: { id :: String }, index :: UInt } + } <- decodeAeson errorData + pure $ AdditionalUtxoOverlap $ map + (\elem -> { txId: elem.transaction.id, index: elem.index }) + res.overlappingOutputReferences + -- All other errors + _ -> pure $ UnparsedError $ stringifyAeson aeson + + where + parseElem elem = do + res :: { validator :: OgmiosRedeemerPtr, error :: ScriptFailure } <- + decodeAeson elem + (_ /\ res.error) <$> decodeRedeemerPointer res.validator + + collectIntoMap :: forall k v. Ord k => Array (k /\ v) -> Map k (List v) + collectIntoMap = foldl + ( \m (k /\ v) -> Map.alter + (maybe (Just $ List.singleton v) (Just <<< List.Cons v)) + k + m + ) + Map.empty + +---------------- PROTOCOL PARAMETERS QUERY RESPONSE & PARSING + +-- | A version of `Rational` with Aeson instance that decodes from `x/y` +-- | representation, instead of `{ numerator, denominator }` +newtype PParamRational = PParamRational Rational + +derive instance Newtype PParamRational _ +derive instance Generic PParamRational _ + +instance Show PParamRational where + show = genericShow + +instance DecodeAeson PParamRational where + decodeAeson = + caseAesonString (Left err) + \string -> do + case String.split (Pattern "/") string of + [ numeratorStr, denominatorStr ] -> note err do + numerator <- BigInt.fromString numeratorStr + denominator <- BigInt.fromString denominatorStr + PParamRational <$> numerator % denominator + _ -> Left err + where + err :: JsonDecodeError + err = TypeMismatch "PParamRaional" + +rationalToSubcoin :: PParamRational -> Maybe UnitInterval +rationalToSubcoin (PParamRational rat) = do + numerator <- BigNum.fromBigInt $ Rational.numerator rat + denominator <- BigNum.fromBigInt $ Rational.denominator rat + pure $ UnitInterval { numerator, denominator } + +type OgmiosAdaLovelace = { "ada" :: { "lovelace" :: BigNum } } +type OgmiosBytes = { "bytes" :: UInt } + +-- | A type that corresponds to Ogmios response. +type ProtocolParametersRaw = + { "minFeeCoefficient" :: UInt + , "minFeeConstant" :: OgmiosAdaLovelace + , "minUtxoDepositCoefficient" :: BigNum + , "maxBlockBodySize" :: OgmiosBytes + , "maxBlockHeaderSize" :: OgmiosBytes + , "maxTransactionSize" :: OgmiosBytes + , "maxValueSize" :: OgmiosBytes + , "stakeCredentialDeposit" :: OgmiosAdaLovelace + , "stakePoolDeposit" :: OgmiosAdaLovelace + , "stakePoolRetirementEpochBound" :: UInt + , "desiredNumberOfStakePools" :: UInt + , "stakePoolPledgeInfluence" :: PParamRational + , "monetaryExpansion" :: PParamRational + , "treasuryExpansion" :: PParamRational + , "version" :: + { "major" :: UInt + , "minor" :: UInt + } + , "minStakePoolCost" :: OgmiosAdaLovelace + , "plutusCostModels" :: + { "plutus:v1" :: Array Cardano.Int + , "plutus:v2" :: Maybe (Array Cardano.Int) + , "plutus:v3" :: Maybe (Array Cardano.Int) + } + , "scriptExecutionPrices" :: + { "memory" :: PParamRational + , "cpu" :: PParamRational + } + , "maxExecutionUnitsPerTransaction" :: + { "memory" :: BigNum + , "cpu" :: BigNum + } + , "maxExecutionUnitsPerBlock" :: + { "memory" :: BigNum + , "cpu" :: BigNum + } + , "collateralPercentage" :: UInt + , "maxCollateralInputs" :: UInt + , "governanceActionDeposit" :: Maybe OgmiosAdaLovelace + , "delegateRepresentativeDeposit" :: Maybe OgmiosAdaLovelace + , "minFeeReferenceScripts" :: + { range :: UInt + , base :: Number + , multiplier :: Number + } + } + +newtype OgmiosProtocolParameters = OgmiosProtocolParameters ProtocolParameters + +derive instance Newtype OgmiosProtocolParameters _ +derive instance Generic OgmiosProtocolParameters _ +derive instance Eq OgmiosProtocolParameters + +instance Show OgmiosProtocolParameters where + show = genericShow + +instance DecodeAeson OgmiosProtocolParameters where + decodeAeson aeson = do + ps :: ProtocolParametersRaw <- decodeAeson aeson + prices <- decodePrices ps + minFeeReferenceScriptsBase <- + note (TypeMismatch "minFeeReferenceScripts.multiplier: expected a number") + $ Rational.fromNumber ps.minFeeReferenceScripts.base + pure $ OgmiosProtocolParameters $ ProtocolParameters + { protocolVersion: ps.version.major /\ ps.version.minor + -- The following two parameters were removed from Babbage + , decentralization: zero + , maxBlockHeaderSize: ps.maxBlockHeaderSize.bytes + , maxBlockBodySize: ps.maxBlockBodySize.bytes + , maxTxSize: ps.maxTransactionSize.bytes + , txFeeFixed: wrap ps.minFeeConstant.ada.lovelace + , txFeePerByte: ps.minFeeCoefficient + , stakeAddressDeposit: wrap ps.stakeCredentialDeposit.ada.lovelace + , stakePoolDeposit: wrap ps.stakePoolDeposit.ada.lovelace + , minPoolCost: wrap ps.minStakePoolCost.ada.lovelace + , poolRetireMaxEpoch: wrap ps.stakePoolRetirementEpochBound + , stakePoolTargetNum: ps.desiredNumberOfStakePools + , poolPledgeInfluence: unwrap ps.stakePoolPledgeInfluence + , monetaryExpansion: unwrap ps.monetaryExpansion + , treasuryCut: unwrap ps.treasuryExpansion -- Rational + , coinsPerUtxoByte: wrap ps.minUtxoDepositCoefficient + , costModels: Map.fromFoldable $ catMaybes + [ pure + ( PlutusV1 /\ CostModel + ps.plutusCostModels."plutus:v1" + ) + , Tuple PlutusV2 <<< CostModel <$> + ps.plutusCostModels."plutus:v2" + , Tuple PlutusV3 <<< CostModel <$> + ps.plutusCostModels."plutus:v3" + ] + , prices: prices + , maxTxExUnits: decodeExUnits ps.maxExecutionUnitsPerTransaction + , maxBlockExUnits: decodeExUnits ps.maxExecutionUnitsPerBlock + , maxValueSize: ps.maxValueSize.bytes + , collateralPercent: ps.collateralPercentage + , maxCollateralInputs: ps.maxCollateralInputs + , govActionDeposit: + -- NOTE: Conway fields should be optional to enable integration tests. + -- Reason: cardano-testnet runs in the Babbage era. + maybe mempty (wrap <<< _.ada.lovelace) ps.governanceActionDeposit + , drepDeposit: + maybe mempty (wrap <<< _.ada.lovelace) + ps.delegateRepresentativeDeposit + , refScriptCoinsPerByte: minFeeReferenceScriptsBase + } + where + decodeExUnits + :: { memory :: BigNum, cpu :: BigNum } -> ExUnits + decodeExUnits { memory, cpu } = ExUnits { mem: memory, steps: cpu } + + decodePrices + :: ProtocolParametersRaw -> Either JsonDecodeError ExUnitPrices + decodePrices ps = note (TypeMismatch "ExUnitPrices") $ ExUnitPrices <$> do + memPrice <- rationalToSubcoin ps.scriptExecutionPrices.memory + stepPrice <- rationalToSubcoin ps.scriptExecutionPrices.cpu + pure { memPrice, stepPrice } -- ExUnits + +instance DecodeOgmios OgmiosProtocolParameters where + decodeOgmios = decodeResult decodeAeson + +---------------- CHAIN TIP QUERY RESPONSE & PARSING + +data ChainTipQR + = CtChainOrigin ChainOrigin + | CtChainPoint ChainPoint + +derive instance Generic ChainTipQR _ + +instance Show ChainTipQR where + show = genericShow + +instance DecodeAeson ChainTipQR where + decodeAeson j = do + r :: (ChainOrigin |+| ChainPoint) <- decodeAeson j + pure $ either CtChainOrigin CtChainPoint $ toEither1 r + +instance DecodeOgmios ChainTipQR where + decodeOgmios = decodeResult decodeAeson + +-- | A Blake2b 32-byte digest of an era-independent block header, serialized as +-- CBOR in base16 +newtype OgmiosBlockHeaderHash = OgmiosBlockHeaderHash String + +derive instance Eq OgmiosBlockHeaderHash +derive newtype instance DecodeAeson OgmiosBlockHeaderHash +derive instance Generic OgmiosBlockHeaderHash _ +derive instance Newtype OgmiosBlockHeaderHash _ + +instance Show OgmiosBlockHeaderHash where + show = genericShow + +-- | The origin of the blockchain. It doesn't point to any existing slots, but +-- is preceding any existing other point. +newtype ChainOrigin = ChainOrigin String + +derive instance Eq ChainOrigin +derive newtype instance DecodeAeson ChainOrigin +derive newtype instance HasRuntimeType ChainOrigin +derive instance Generic ChainOrigin _ + +instance Show ChainOrigin where + show = genericShow + +-- | A point on the chain, identified by a slot and a block header hash +type ChainPoint = + { slot :: Slot -- See https://github.com/Plutonomicon/cardano-transaction-lib/issues/632 + -- for details on why we lose a negligible amount of precision. + , id :: OgmiosBlockHeaderHash + } + +---------------- ADDITIONAL UTXO MAP REQUEST + +newtype AdditionalUtxoSet = AdditionalUtxoSet OgmiosUtxoMap + +derive instance Newtype AdditionalUtxoSet _ + +derive newtype instance Show AdditionalUtxoSet + +-- Ogmios tx input +type OgmiosTxOutRef = + { txId :: String + , index :: UInt + } + +type OgmiosTxOut = + { address :: OgmiosAddress + , value :: Value + , datumHash :: Maybe String + , datum :: Maybe String + , script :: Maybe ScriptRef + } + +type OgmiosUtxoMap = Map OgmiosTxOutRef OgmiosTxOut + +instance EncodeAeson AdditionalUtxoSet where + encodeAeson (AdditionalUtxoSet m) = + encodeAeson $ encode <$> utxos + + where + utxos :: Array (OgmiosTxOutRef /\ OgmiosTxOut) + utxos = Map.toUnfoldable m + + encode :: (OgmiosTxOutRef /\ OgmiosTxOut) -> Aeson + encode (inp /\ out) = encodeAeson $ + { "transaction": { "id": inp.txId } + , "index": inp.index + , "address": out.address + , "datumHash": out.datumHash + , "datum": out.datum + , "script": encodeScriptRef <$> out.script + , "value": encodeValue out.value + } + + encodeNativeScript :: NativeScript -> Aeson + encodeNativeScript (ScriptPubkey s) = + encodeAeson { "clause": "signature", "from": encodeAeson s } + encodeNativeScript (ScriptAll ss) = + encodeAeson { "clause": "all", "from": encodeNativeScript <$> ss } + encodeNativeScript (ScriptAny ss) = + encodeAeson { "clause": "any", "from": encodeNativeScript <$> ss } + encodeNativeScript (ScriptNOfK n ss) = + encodeAeson + { "clause": "some" + , "atLeast": BigInt.fromInt n + , "from": encodeNativeScript <$> ss + } + encodeNativeScript (TimelockStart (Slot n)) = + encodeAeson { "clause": "after", "slot": n } + encodeNativeScript (TimelockExpiry (Slot n)) = + encodeAeson { "clause": "before", "slot": n } + + encodeScriptRef :: ScriptRef -> Aeson + encodeScriptRef (NativeScriptRef s) = + encodeAeson + { "language": "native" + -- NOTE: We omit the cbor argument. + , "json": (encodeNativeScript s) + } + encodeScriptRef (PlutusScriptRef (PlutusScript (script /\ lang))) = + encodeAeson + { "language": + case lang of + PlutusV1 -> "plutus:v1" + PlutusV2 -> "plutus:v2" + PlutusV3 -> "plutus:v3" + , "cbor": byteArrayToHex script + } + + encodeValue :: Value -> Aeson + encodeValue value = encodeMap $ map encodeMap $ Map.union adaPart nonAdaPart + where + adaPart = Map.fromFoldable + [ ( "ada" /\ + ( Map.fromFoldable + [ ("lovelace" /\ (value # valueToCoin # unwrap)) ] + ) + ) + ] + nonAdaPart = mapKeys (byteArrayToHex <<< unwrap <<< encodeCbor) + $ map (mapKeys (byteArrayToHex <<< unAssetName)) + $ unwrap + $ getMultiAsset value + + mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a + mapKeys f = (Map.toUnfoldable :: Map k1 a -> Array (k1 /\ a)) >>> foldl + (\m' (k /\ v) -> Map.insert (f k) v m') + Map.empty + +-- helper for assuming we get an object +aesonObject + :: forall (a :: Type) + . (Object Aeson -> Either JsonDecodeError a) + -> Aeson + -> Either JsonDecodeError a +aesonObject = caseAesonObject (Left (TypeMismatch "Expected Object")) + +-- helper for assuming we get an array +aesonArray + :: forall (a :: Type) + . (Array Aeson -> Either JsonDecodeError a) + -> Aeson + -> Either JsonDecodeError a +aesonArray = caseAesonArray (Left (TypeMismatch "Expected Array")) + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +ogmiosPostRequest + :: Aeson -- ^ JSON-RPC request body + -> QueryM (Either Affjax.Error (Affjax.Response String)) +ogmiosPostRequest body = do + config <- asks (_.ogmiosConfig <<< _.config) + logTrace' $ "sending ogmios HTTP request: " <> show body + liftAff $ ogmiosPostRequestAff config body + +ogmiosPostRequestAff + :: ServerConfig + -> Aeson + -> Aff (Either Affjax.Error (Affjax.Response String)) +ogmiosPostRequestAff = ogmiosPostRequestRetryAff (Milliseconds 1000.0) + +ogmiosPostRequestRetryAff + :: Milliseconds + -> ServerConfig + -> Aeson + -> Aff (Either Affjax.Error (Affjax.Response String)) +ogmiosPostRequestRetryAff delayMs config body = do + let + req = Affjax.defaultRequest + { method = Left POST + , url = mkHttpUrl config + , headers = + [ Affjax.RequestHeader.RequestHeader "Content-Type" + "application/json" + ] + , content = Just $ Affjax.RequestBody.String $ stringifyAeson body + , responseFormat = Affjax.ResponseFormat.string + } + + result <- Affjax.request req + + if result ^? _Right <<< to _.status == Just (StatusCode 503) then + delay delayMs *> + ogmiosPostRequestRetryAff (Milliseconds (unwrap delayMs * 2.0)) config + body + + else pure result + +handleAffjaxOgmiosResponse + :: forall (result :: Type) + . DecodeOgmios result + => Either Affjax.Error (Affjax.Response String) + -> Either OgmiosDecodeError result +handleAffjaxOgmiosResponse (Left affjaxError) = + Left (ClientErrorResponse $ ClientHttpError affjaxError) +handleAffjaxOgmiosResponse + (Right { status: Affjax.StatusCode.StatusCode statusCode, body }) + | statusCode < 200 || statusCode > 299 = + Left $ ClientErrorResponse $ ClientHttpResponseError (wrap statusCode) $ + ServiceOtherError body + | otherwise = do + aeson <- lmap ResultDecodingError + $ parseJsonStringToAeson body + decodeOgmios aeson + +ogmiosErrorHandler + :: forall a m + . MonadAff m + => MonadThrow Error m + => m (Either OgmiosDecodeError a) + -> m a +ogmiosErrorHandler fun = do + resp <- fun + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure val + +ogmiosErrorHandlerWithArg + :: forall a m b + . MonadAff m + => MonadThrow Error m + => (a -> m (Either OgmiosDecodeError b)) + -> a + -> m b +ogmiosErrorHandlerWithArg fun arg = do + resp <- fun arg + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure val + diff --git a/src/Internal/QueryM/Dispatcher.purs b/src/Internal/QueryM/OgmiosWebsocket/Dispatcher.purs similarity index 98% rename from src/Internal/QueryM/Dispatcher.purs rename to src/Internal/QueryM/OgmiosWebsocket/Dispatcher.purs index 35f8874159..312397b183 100644 --- a/src/Internal/QueryM/Dispatcher.purs +++ b/src/Internal/QueryM/OgmiosWebsocket/Dispatcher.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.Dispatcher +module Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher ( DispatchError(JsonError, FaultError, ListenerCancelled) , Dispatcher , GenericPendingRequests diff --git a/src/Internal/JsWebSocket.js b/src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.js similarity index 100% rename from src/Internal/JsWebSocket.js rename to src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.js diff --git a/src/Internal/JsWebSocket.purs b/src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.purs similarity index 96% rename from src/Internal/JsWebSocket.purs rename to src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.purs index 52590c76e2..c73aa3609f 100644 --- a/src/Internal/JsWebSocket.purs +++ b/src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.JsWebSocket +module Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket ( JsWebSocket , ListenerRef , Url diff --git a/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs b/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs new file mode 100644 index 0000000000..c377ad651e --- /dev/null +++ b/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs @@ -0,0 +1,148 @@ +module Ctl.Internal.QueryM.OgmiosWebsocket.Mempool + ( acquireMempoolSnapshotAff + , mempoolSnapshotHasTxAff + , mempoolSnapshotNextTxAff + , mempoolSnapshotSizeAndCapacityAff + , releaseMempoolAff + , acquireMempoolSnapshotCall + , mempoolSnapshotHasTxCall + , mempoolSnapshotNextTxCall + , mempoolSnapshotSizeAndCapacityCall + , releaseMempoolCall + ) where + +import Prelude + +import Aeson (class EncodeAeson) +import Cardano.Types.TransactionHash (TransactionHash) +import Ctl.Internal.Logging (Logger) +import Ctl.Internal.QueryM.JsonRpc2 + ( class DecodeOgmios + , JsonRpc2Call + , JsonRpc2Request + , mkCallType + ) +import Ctl.Internal.QueryM.Ogmios + ( HasTxR + , MaybeMempoolTransaction + , MempoolSizeAndCapacity + , MempoolSnapshotAcquired + , MempoolTransaction + , ReleasedMempool + , acquireMempoolSnapshotCall + , mempoolSnapshotHasTxCall + , mempoolSnapshotNextTxCall + , mempoolSnapshotSizeAndCapacityCall + , releaseMempoolCall + ) as Ogmios +import Ctl.Internal.QueryM.Ogmios (ReleasedMempool) +import Ctl.Internal.QueryM.OgmiosWebsocket.Types + ( OgmiosWebSocket + , mkOgmiosRequestAff + ) +import Data.Maybe (Maybe) +import Data.Newtype (unwrap) +import Effect.Aff (Aff) + +-------------------------------------------------------------------------------- +-- Ogmios Local Tx Monitor Protocol +-------------------------------------------------------------------------------- + +acquireMempoolSnapshotAff + :: OgmiosWebSocket -> Logger -> Aff Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshotAff ogmiosWs logger = + mkOgmiosRequestAff ogmiosWs logger Ogmios.acquireMempoolSnapshotCall + _.acquireMempool + unit + +mempoolSnapshotHasTxAff + :: OgmiosWebSocket + -> Logger + -> Ogmios.MempoolSnapshotAcquired + -> TransactionHash + -> Aff Boolean +mempoolSnapshotHasTxAff ogmiosWs logger ms txh = + unwrap <$> mkOgmiosRequestAff ogmiosWs logger + (Ogmios.mempoolSnapshotHasTxCall ms) + _.mempoolHasTx + txh + +mempoolSnapshotSizeAndCapacityAff + :: OgmiosWebSocket + -> Logger + -> Ogmios.MempoolSnapshotAcquired + -> Aff Ogmios.MempoolSizeAndCapacity +mempoolSnapshotSizeAndCapacityAff ogmiosWs logger ms = + mkOgmiosRequestAff ogmiosWs logger + (Ogmios.mempoolSnapshotSizeAndCapacityCall ms) + _.mempoolSizeAndCapacity -- todo: typo + unit + +releaseMempoolAff + :: OgmiosWebSocket + -> Logger + -> Ogmios.MempoolSnapshotAcquired + -> Aff ReleasedMempool +releaseMempoolAff ogmiosWs logger ms = + mkOgmiosRequestAff ogmiosWs logger (Ogmios.releaseMempoolCall ms) + _.releaseMempool + unit + +mempoolSnapshotNextTxAff + :: OgmiosWebSocket + -> Logger + -> Ogmios.MempoolSnapshotAcquired + -> Aff (Maybe Ogmios.MempoolTransaction) +mempoolSnapshotNextTxAff ogmiosWs logger ms = unwrap <$> + mkOgmiosRequestAff ogmiosWs logger (Ogmios.mempoolSnapshotNextTxCall ms) + _.mempoolNextTx + unit + +acquireMempoolSnapshotCall :: JsonRpc2Call Unit Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshotCall = + mkOgmiosCallTypeNoArgs "acquireMempool" + +mempoolSnapshotHasTxCall + :: Ogmios.MempoolSnapshotAcquired + -> JsonRpc2Call TransactionHash Ogmios.HasTxR +mempoolSnapshotHasTxCall _ = mkOgmiosCallType + { method: "hasTransaction" + , params: { id: _ } + } + +mempoolSnapshotNextTxCall + :: Ogmios.MempoolSnapshotAcquired + -> JsonRpc2Call Unit Ogmios.MaybeMempoolTransaction +mempoolSnapshotNextTxCall _ = mkOgmiosCallType + { method: "nextTransaction" + , params: const { fields: "all" } + } + +mempoolSnapshotSizeAndCapacityCall + :: Ogmios.MempoolSnapshotAcquired + -> JsonRpc2Call Unit Ogmios.MempoolSizeAndCapacity +mempoolSnapshotSizeAndCapacityCall _ = + mkOgmiosCallTypeNoArgs "sizeOfMempool" + +releaseMempoolCall + :: Ogmios.MempoolSnapshotAcquired -> JsonRpc2Call Unit Ogmios.ReleasedMempool +releaseMempoolCall _ = + mkOgmiosCallTypeNoArgs "releaseMempool" + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +mkOgmiosCallTypeNoArgs + :: forall (o :: Type). DecodeOgmios o => String -> JsonRpc2Call Unit o +mkOgmiosCallTypeNoArgs method = + mkOgmiosCallType { method, params: const {} } + +mkOgmiosCallType + :: forall (a :: Type) (i :: Type) (o :: Type) + . EncodeAeson (JsonRpc2Request a) + => DecodeOgmios o + => { method :: String, params :: i -> a } + -> JsonRpc2Call i o +mkOgmiosCallType = + mkCallType { jsonrpc: "2.0" } diff --git a/src/Internal/QueryM/OgmiosWebsocket/Queries.purs b/src/Internal/QueryM/OgmiosWebsocket/Queries.purs new file mode 100644 index 0000000000..3fd4b3cb99 --- /dev/null +++ b/src/Internal/QueryM/OgmiosWebsocket/Queries.purs @@ -0,0 +1,82 @@ +module Ctl.Internal.QueryM.OgmiosWebsocket.Queries + ( module ExportDispatcher + , module ExportServerConfig + , ClusterSetup + , QueryConfig + , QueryEnv + , QueryRuntime + ) where + +import Prelude + +import Cardano.Wallet.Key (PrivatePaymentKey, PrivateStakeKey) +import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher + ( DispatchError(JsonError, FaultError, ListenerCancelled) + , Dispatcher + , GenericPendingRequests + , PendingRequests + , PendingSubmitTxRequests + , RequestBody + , WebsocketDispatch + , dispatchErrorToError + , mkWebsocketDispatch + , newDispatcher + , newPendingRequests + ) as ExportDispatcher +import Ctl.Internal.QueryM.OgmiosWebsocket.Types (OgmiosWebSocket) +import Ctl.Internal.ServerConfig + ( Host + , ServerConfig + , defaultOgmiosWsConfig + , mkHttpUrl + , mkServerUrl + , mkWsUrl + ) as ExportServerConfig +import Ctl.Internal.ServerConfig (ServerConfig) +import Data.Log.Level (LogLevel) +import Data.Log.Message (Message) +import Data.Maybe (Maybe) +import Effect.Aff (Aff) + +-- | Cluster setup contains everything that is needed to run a `Contract` on +-- | a local cluster: paramters to connect to the services and private keys +-- | that are pre-funded with Ada on that cluster +type ClusterSetup = + { ogmiosConfig :: ServerConfig + , kupoConfig :: ServerConfig + , keys :: + { payment :: PrivatePaymentKey + , stake :: Maybe PrivateStakeKey + } + } + +-- | `QueryConfig` contains a complete specification on how to initialize a +-- | `QueryM` environment. +-- | It includes: +-- | - server parameters for all the services +-- | - network ID +-- | - logging level +-- | - optional custom logger +type QueryConfig = + { ogmiosConfig :: ServerConfig + , kupoConfig :: ServerConfig + , logLevel :: LogLevel + , customLogger :: Maybe (LogLevel -> Message -> Aff Unit) + , suppressLogs :: Boolean + } + +-- | Reusable part of `QueryRuntime` that can be shared between many `QueryM` +-- | instances running in parallel. +-- | +-- | Includes: +-- | - WebSocket connections +type QueryRuntime = + { ogmiosWs :: OgmiosWebSocket + } + +-- | `QueryEnv` contains everything needed for `QueryM` to run. +type QueryEnv = + { config :: QueryConfig + , runtime :: QueryRuntime + } + diff --git a/src/Internal/QueryM/OgmiosWebsocket/Types.purs b/src/Internal/QueryM/OgmiosWebsocket/Types.purs new file mode 100644 index 0000000000..f3bab24c08 --- /dev/null +++ b/src/Internal/QueryM/OgmiosWebsocket/Types.purs @@ -0,0 +1,559 @@ +module Ctl.Internal.QueryM.OgmiosWebsocket.Types + ( module ExportDispatcher + , module ExportServerConfig + , ListenerSet + , OgmiosListeners + , OgmiosWebSocket + , SubmitTxListenerSet + , WebSocket(WebSocket) + , listeners + , mkListenerSet + , defaultMessageListener + , mkOgmiosRequestAff + , mkOgmiosWebSocketAff + , mkRequestAff + , underlyingWebSocket + , mkOgmiosWebSocketLens + , mkSubmitTxListenerSet + , MkServiceWebSocketLens + ) where + +import Prelude + +import Aeson + ( Aeson + , JsonDecodeError(TypeMismatch) + , encodeAeson + , parseJsonStringToAeson + , stringifyAeson + ) +import Cardano.Types.CborBytes (CborBytes) +import Cardano.Types.TransactionHash (TransactionHash) +import Control.Monad.Error.Class (liftEither, throwError) +import Ctl.Internal.Logging (Logger) +import Ctl.Internal.QueryM.JsonRpc2 + ( OgmiosDecodeError + , decodeOgmios + , ogmiosDecodeErrorToError + ) +import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 +import Ctl.Internal.QueryM.Ogmios + ( AdditionalUtxoSet + , DelegationsAndRewardsR + , HasTxR + , MaybeMempoolTransaction + , OgmiosProtocolParameters + , OgmiosTxEvaluationR + , PoolParametersR + , ReleasedMempool + , StakePoolsQueryArgument + ) +import Ctl.Internal.QueryM.Ogmios as Ogmios +import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher + ( DispatchError(JsonError) + , Dispatcher + , GenericPendingRequests + , PendingRequests + , PendingSubmitTxRequests + , RequestBody + , WebsocketDispatch + , mkWebsocketDispatch + , newDispatcher + , newPendingRequests + ) +import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher + ( DispatchError(JsonError, FaultError, ListenerCancelled) + , Dispatcher + , GenericPendingRequests + , PendingRequests + , PendingSubmitTxRequests + , RequestBody + , WebsocketDispatch + , dispatchErrorToError + , mkWebsocketDispatch + , newDispatcher + , newPendingRequests + ) as ExportDispatcher +import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket + ( JsWebSocket + , Url + , _mkWebSocket + , _onWsConnect + , _onWsError + , _onWsMessage + , _removeOnWsError + , _wsClose + , _wsFinalize + , _wsSend + ) +import Ctl.Internal.QueryM.UniqueId (ListenerId) +import Ctl.Internal.ServerConfig + ( Host + , ServerConfig + , defaultOgmiosWsConfig + , mkHttpUrl + , mkServerUrl + , mkWsUrl + ) as ExportServerConfig +import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) +import Data.Bifunctor (lmap) +import Data.Either (Either(Left, Right), either, isRight) +import Data.Foldable (foldl) +import Data.Log.Level (LogLevel(Error, Debug)) +import Data.Map as Map +import Data.Maybe (Maybe(Just, Nothing), maybe) +import Data.Newtype (unwrap, wrap) +import Data.Traversable (for_, traverse_) +import Data.Tuple (fst) +import Data.Tuple.Nested (type (/\), (/\)) +import Effect (Effect) +import Effect.Aff (Aff, Canceler(Canceler), delay, launchAff_, makeAff, runAff_) +import Effect.Class (liftEffect) +import Effect.Exception (Error, error) +import Effect.Ref as Ref + +mempoolSnapshotHasTxAff + :: OgmiosWebSocket + -> Logger + -> Ogmios.MempoolSnapshotAcquired + -> TransactionHash + -> Aff Boolean +mempoolSnapshotHasTxAff ogmiosWs logger ms txh = + unwrap <$> mkOgmiosRequestAff ogmiosWs logger + (Ogmios.mempoolSnapshotHasTxCall ms) + _.mempoolHasTx + txh + +acquireMempoolSnapshotAff + :: OgmiosWebSocket -> Logger -> Aff Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshotAff ogmiosWs logger = + mkOgmiosRequestAff ogmiosWs logger Ogmios.acquireMempoolSnapshotCall + _.acquireMempool + unit + +withMempoolSnapshot + :: OgmiosWebSocket + -> Logger + -> (Maybe Ogmios.MempoolSnapshotAcquired -> Aff Unit) + -> Effect Unit +withMempoolSnapshot ogmiosWs logger cont = + flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of + Left err -> do + logger Error $ + "Failed to acquire a mempool snapshot: Error: " <> show err + launchAff_ (cont Nothing) + Right mempoolSnapshot -> + launchAff_ (cont $ Just mempoolSnapshot) + +-------------------------------------------------------------------------------- +-- Type-safe `WebSocket` +-------------------------------------------------------------------------------- + +-- don't export this constructor +-- type-safe websocket which has automated req/res dispatch and websocket +-- failure handling +data WebSocket listeners = WebSocket JsWebSocket listeners +type OgmiosWebSocket = WebSocket OgmiosListeners + +-- getter +underlyingWebSocket :: forall (a :: Type). WebSocket a -> JsWebSocket +underlyingWebSocket (WebSocket ws _) = ws + +-- getter +listeners :: forall (listeners :: Type). WebSocket listeners -> listeners +listeners (WebSocket _ ls) = ls + +-------------------------------------------------------------------------------- +-- OgmiosWebSocket Setup and PrimOps +-------------------------------------------------------------------------------- + +type IsTxConfirmed = TransactionHash -> Aff Boolean + +mkOgmiosWebSocketAff + :: IsTxConfirmed + -> Logger + -> ServerConfig + -> Aff OgmiosWebSocket +mkOgmiosWebSocketAff isTxConfirmed logger serverConfig = do + lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed + makeAff $ mkServiceWebSocket lens (mkWsUrl serverConfig) + +mkServiceWebSocket + :: forall (listeners :: Type) + . MkServiceWebSocketLens listeners + -> Url + -> (Either Error (WebSocket listeners) -> Effect Unit) + -> Effect Canceler +mkServiceWebSocket lens url continue = do + ws <- _mkWebSocket (lens.logger Debug) url + let + messageDispatch :: WebsocketDispatch + messageDispatch = mkWebsocketDispatch lens.dispatcher + + -- We want to fail if the first connection attempt is not successful. + -- Otherwise, we start reconnecting indefinitely. + onFirstConnectionError :: String -> Effect Unit + onFirstConnectionError errMessage = do + _wsFinalize ws + _wsClose ws + lens.logger Error $ + "First connection to " <> lens.serviceName <> " WebSocket failed. " + <> "Terminating. Error: " + <> errMessage + continue $ Left $ error errMessage + firstConnectionErrorRef <- _onWsError ws onFirstConnectionError + hasConnectedOnceRef <- Ref.new false + _onWsConnect ws $ Ref.read hasConnectedOnceRef >>= case _ of + true -> do + lens.logger Debug $ + lens.serviceName <> + " WebSocket connection re-established, resending pending requests..." + lens.resendPendingRequests ws + false -> do + lens.logger Debug $ "Connection to " <> lens.serviceName <> " established" + Ref.write true hasConnectedOnceRef + _removeOnWsError ws firstConnectionErrorRef + _onWsMessage ws (lens.logger Debug) $ defaultMessageListener lens.logger + [ messageDispatch ] + void $ _onWsError ws \err -> do + lens.logger Debug $ + lens.serviceName <> " WebSocket error (" <> err <> + "). Reconnecting..." + continue $ Right (lens.typedWebSocket ws) + pure $ Canceler $ \err -> liftEffect do + _wsFinalize ws + _wsClose ws + continue $ Left $ err + +-------------------------------------------------------------------------------- +-- Resend pending `SubmitTx` requests +-------------------------------------------------------------------------------- + +-- | For each pending `SubmitTx` request, checks whether the transaction has +-- | been added to the mempool or has been included in a block before retrying +-- | the request. +resendPendingSubmitRequests + :: OgmiosWebSocket + -> IsTxConfirmed + -> Logger + -> (RequestBody -> Effect Unit) + -> Dispatcher + -> PendingSubmitTxRequests + -> Effect Unit +resendPendingSubmitRequests + ogmiosWs + isTxConfirmed + logger + sendRequest + dispatcher + pr = do + submitTxPendingRequests <- Ref.read pr + unless (Map.isEmpty submitTxPendingRequests) do + -- Acquiring a mempool snapshot should never fail and, + -- after ws reconnection, should be instantaneous. + withMempoolSnapshot ogmiosWs logger case _ of + Nothing -> + liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests + Just ms -> do + -- A delay of 5 sec for transactions to be processed by the node + -- and added to the mempool: + delay (wrap 5000.0) + let (pr' :: Array _) = Map.toUnfoldable submitTxPendingRequests + for_ pr' \(listenerId /\ requestBody /\ txHash) -> + handlePendingSubmitRequest ms listenerId requestBody txHash + where + log :: String -> Boolean -> TransactionHash -> Aff Unit + log label value txHash = + liftEffect $ logger Debug $ + label <> ": " <> show value <> " TransactionHash: " <> show txHash + + handlePendingSubmitRequest + :: Ogmios.MempoolSnapshotAcquired + -> ListenerId + -> RequestBody + -> TransactionHash + -> Aff Unit + handlePendingSubmitRequest ms listenerId requestBody txHash = do + -- Check if the transaction was added to the mempool: + txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash + log "Tx in the mempool" txInMempool txHash + retrySubmitTx <- + if txInMempool then pure false + else do + -- Check if the transaction was included in the block: + txConfirmed <- isTxConfirmed txHash + log "Tx confirmed" txConfirmed txHash + unless txConfirmed $ liftEffect do + sendRequest requestBody + pure (not txConfirmed) + -- Manually dispatch `SubmitTx` response if resending is not required: + unless retrySubmitTx $ liftEffect do + Ref.modify_ (Map.delete listenerId) pr + dispatchMap <- Ref.read dispatcher + Ref.modify_ (Map.delete listenerId) dispatcher + Map.lookup listenerId dispatchMap # + maybe (pure unit) (_ $ submitSuccessPartialResp) + where + submitSuccessPartialResp :: Aeson + submitSuccessPartialResp = + encodeAeson $ Ogmios.submitSuccessPartialResp txHash + +-------------------------------------------------------------------------------- +-- `MkServiceWebSocketLens` for ogmios +-------------------------------------------------------------------------------- + +type MkServiceWebSocketLens (listeners :: Type) = + { serviceName :: String + , dispatcher :: Dispatcher + , logger :: Logger + , typedWebSocket :: JsWebSocket -> WebSocket listeners + , resendPendingRequests :: JsWebSocket -> Effect Unit + } + +mkOgmiosWebSocketLens + :: Logger + -> IsTxConfirmed + -> Effect (MkServiceWebSocketLens OgmiosListeners) +mkOgmiosWebSocketLens logger isTxConfirmed = do + dispatcher <- newDispatcher + pendingRequests <- newPendingRequests + pendingSubmitTxRequests <- newPendingRequests + pure $ + let + ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket + ogmiosWebSocket ws = WebSocket ws + { chainTip: + mkListenerSet dispatcher pendingRequests + , evaluate: + mkListenerSet dispatcher pendingRequests + , getProtocolParameters: + mkListenerSet dispatcher pendingRequests + , eraSummaries: + mkListenerSet dispatcher pendingRequests + , currentEpoch: + mkListenerSet dispatcher pendingRequests + , systemStart: + mkListenerSet dispatcher pendingRequests + , acquireMempool: + mkListenerSet dispatcher pendingRequests + , releaseMempool: + mkListenerSet dispatcher pendingRequests + , mempoolHasTx: + mkListenerSet dispatcher pendingRequests + , mempoolNextTx: + mkListenerSet dispatcher pendingRequests + , mempoolSizeAndCapacity: + mkListenerSet dispatcher pendingRequests + , submit: + mkSubmitTxListenerSet dispatcher pendingSubmitTxRequests + , stakePools: + mkListenerSet dispatcher pendingRequests + , delegationsAndRewards: + mkListenerSet dispatcher pendingRequests + } + + resendPendingRequests :: JsWebSocket -> Effect Unit + resendPendingRequests ws = do + let sendRequest = _wsSend ws (logger Debug) + Ref.read pendingRequests >>= traverse_ sendRequest + resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed + logger + sendRequest + dispatcher + pendingSubmitTxRequests + in + { serviceName: "ogmios" + , dispatcher + , logger + , typedWebSocket: ogmiosWebSocket + , resendPendingRequests + } + +-------------------------------------------------------------------------------- +-- ListenerSet +-------------------------------------------------------------------------------- + +type OgmiosListeners = + { chainTip :: ListenerSet Unit Ogmios.ChainTipQR + , submit :: SubmitTxListenerSet + , evaluate :: + ListenerSet (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR + , getProtocolParameters :: ListenerSet Unit OgmiosProtocolParameters + , eraSummaries :: ListenerSet Unit Ogmios.OgmiosEraSummaries + , currentEpoch :: ListenerSet Unit Ogmios.CurrentEpoch + , systemStart :: ListenerSet Unit Ogmios.OgmiosSystemStart + , acquireMempool :: ListenerSet Unit Ogmios.MempoolSnapshotAcquired + , releaseMempool :: ListenerSet Unit ReleasedMempool + , mempoolHasTx :: ListenerSet TransactionHash HasTxR + , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction + , mempoolSizeAndCapacity :: ListenerSet Unit Ogmios.MempoolSizeAndCapacity + , stakePools :: ListenerSet StakePoolsQueryArgument PoolParametersR + , delegationsAndRewards :: ListenerSet (Array String) DelegationsAndRewardsR + } + +-- convenience type for adding additional query types later +type ListenerSet (request :: Type) (response :: Type) = + { addMessageListener :: + ListenerId + -> (Either OgmiosDecodeError response -> Effect Unit) + -> Effect Unit + , removeMessageListener :: ListenerId -> Effect Unit + -- ^ Removes ID from dispatch map and pending requests queue. + , addRequest :: ListenerId -> RequestBody /\ request -> Effect Unit + -- ^ Saves request body until the request is fulfilled. The body is used + -- to replay requests in case of a WebSocket failure. + } + +type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) + Ogmios.SubmitTxR + +mkAddMessageListener + :: forall (response :: Type) + . JsonRpc2.DecodeOgmios response + => Dispatcher + -> ( ListenerId + -> (Either JsonRpc2.OgmiosDecodeError response -> Effect Unit) + -> Effect Unit + ) +mkAddMessageListener dispatcher = + \reflection handler -> + flip Ref.modify_ dispatcher $ + Map.insert reflection + (\aeson -> handler $ decodeOgmios aeson) + +mkRemoveMessageListener + :: forall (requestData :: Type) + . Dispatcher + -> GenericPendingRequests requestData + -> (ListenerId -> Effect Unit) +mkRemoveMessageListener dispatcher pendingRequests = + \reflection -> do + Ref.modify_ (Map.delete reflection) dispatcher + Ref.modify_ (Map.delete reflection) pendingRequests + +-- we manipluate closures to make the DispatchIdMap updateable using these +-- methods, this can be picked up by a query or cancellation function +mkListenerSet + :: forall (request :: Type) (response :: Type) + . JsonRpc2.DecodeOgmios response + => Dispatcher + -> PendingRequests + -> ListenerSet request response +mkListenerSet dispatcher pendingRequests = + { addMessageListener: + mkAddMessageListener dispatcher + , removeMessageListener: + mkRemoveMessageListener dispatcher pendingRequests + , addRequest: + \reflection (requestBody /\ _) -> + Ref.modify_ (Map.insert reflection requestBody) pendingRequests + } + +mkSubmitTxListenerSet + :: Dispatcher -> PendingSubmitTxRequests -> SubmitTxListenerSet +mkSubmitTxListenerSet dispatcher pendingRequests = + { addMessageListener: + mkAddMessageListener dispatcher + , removeMessageListener: + mkRemoveMessageListener dispatcher pendingRequests + , addRequest: + \reflection (requestBody /\ txHash /\ _) -> + Ref.modify_ (Map.insert reflection (requestBody /\ txHash)) + pendingRequests + } + +-- | Builds an Ogmios request action using `Aff` +mkOgmiosRequestAff + :: forall (request :: Type) (response :: Type) + . OgmiosWebSocket + -> Logger + -> JsonRpc2.JsonRpc2Call request response + -> (OgmiosListeners -> ListenerSet request response) + -> request + -> Aff response +mkOgmiosRequestAff ogmiosWs = mkRequestAff + (listeners ogmiosWs) + (underlyingWebSocket ogmiosWs) + +mkRequestAff + :: forall (request :: Type) (response :: Type) (listeners :: Type) + . listeners + -> JsWebSocket + -> Logger + -> JsonRpc2.JsonRpc2Call request response + -> (listeners -> ListenerSet request response) + -> request + -> Aff response +mkRequestAff listeners' webSocket logger jsonRpc2Call getLs input = do + { body, id } <- + liftEffect $ JsonRpc2.buildRequest jsonRpc2Call input + let + respLs :: ListenerSet request response + respLs = getLs listeners' + + sBody :: RequestBody + sBody = stringifyAeson body + + affFunc :: (Either Error response -> Effect Unit) -> Effect Canceler + affFunc cont = do + _ <- respLs.addMessageListener id + ( \res -> do + respLs.removeMessageListener id + cont $ lmap ogmiosDecodeErrorToError res + ) + respLs.addRequest id (sBody /\ input) + _wsSend webSocket (logger Debug) sBody + -- Uncomment this code fragment to test `SubmitTx` request resend logic: + -- let method = aesonObject (flip getFieldOptional "methodname") body + -- when (method == Right (Just "SubmitTx")) do + -- _wsReconnect webSocket + pure $ Canceler $ \err -> do + liftEffect $ respLs.removeMessageListener id + liftEffect $ throwError $ err + makeAff affFunc + +-- an empty error we can compare to, useful for ensuring we've not received any other kind of error +defaultErr :: JsonDecodeError +defaultErr = TypeMismatch "default error" + +defaultMessageListener + :: Logger + -> Array WebsocketDispatch + -> String + -> Effect Unit +defaultMessageListener logger dispatchArray msg = do + aeson <- liftEither $ lmap (const $ error "Unable to parse response") $ + parseJsonStringToAeson msg + -- here, we need to fold the input over the array of functions until we get + -- a success, then execute the effect. + -- using a fold instead of a traverse allows us to skip a bunch of execution + eAction :: Either DispatchError (Effect Unit) <- foldl + (messageFoldF aeson) + (pure $ Left $ JsonError defaultErr) + dispatchArray + either + -- we expect a lot of parse errors, some messages (could?) fall through completely + ( \err -> + unless + ( case err of + JsonError jsonErr -> jsonErr == defaultErr + _ -> false + ) + do + logger Error $ + "unexpected error on input: " <> msg + <> " Error:" + <> show err + ) + identity + eAction + +messageFoldF + :: Aeson + -> Effect (Either DispatchError (Effect Unit)) + -> (Aeson -> (Effect (Either DispatchError (Effect Unit)))) + -> Effect (Either DispatchError (Effect Unit)) +messageFoldF msg acc' func = do + acc <- acc' + if isRight acc then acc' else func msg + diff --git a/src/Internal/QueryM/Pools.purs b/src/Internal/QueryM/Pools.purs index 69346bfb96..f6a27602f5 100644 --- a/src/Internal/QueryM/Pools.purs +++ b/src/Internal/QueryM/Pools.purs @@ -13,15 +13,15 @@ import Cardano.Types (PoolParams, PoolPubKeyHash, StakePubKeyHash) import Cardano.Types.DelegationsAndRewards (DelegationsAndRewards) import Cardano.Types.Ed25519KeyHash (toBech32Unsafe) as Ed25519KeyHash import Cardano.Types.ScriptHash as ScriptHash +import Control.Monad.Error.Class (throwError) import Ctl.Internal.Helpers (liftM) -import Ctl.Internal.QueryM (QueryM, mkOgmiosRequest) -import Ctl.Internal.QueryM.Ogmios - ( DelegationsAndRewardsR(DelegationsAndRewardsR) - , PoolParameters - ) -import Ctl.Internal.QueryM.Ogmios as Ogmios +import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) +import Ctl.Internal.QueryM.Ogmios (PoolParameters) +import Ctl.Internal.QueryM.OgmiosHttp as OgmiosHttp import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) import Data.ByteArray (byteArrayToHex) +import Data.Either (Either(Right, Left)) import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(Nothing, Just)) @@ -35,10 +35,11 @@ import Record.Builder (build, merge) getStakePools :: Maybe (Array PoolPubKeyHash) -> QueryM (Map PoolPubKeyHash PoolParameters) -getStakePools selected = unwrap <$> - mkOgmiosRequest Ogmios.queryStakePoolsCall - _.stakePools - (wrap selected) +getStakePools selected = do + resp <- OgmiosHttp.poolParameters $ wrap selected + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure $ unwrap val getPoolIds :: QueryM (Array PoolPubKeyHash) getPoolIds = (Map.toUnfoldableUnordered >>> map fst) <$> @@ -70,11 +71,10 @@ getPoolsParameters poolPubKeyHashes = do getValidatorHashDelegationsAndRewards :: StakeValidatorHash -> QueryM (Maybe DelegationsAndRewards) getValidatorHashDelegationsAndRewards skh = do - DelegationsAndRewardsR mp <- mkOgmiosRequest Ogmios.queryDelegationsAndRewards - _.delegationsAndRewards - [ stringRep - ] - pure $ Map.lookup byteHex mp + resp <- OgmiosHttp.delegationsAndRewards [ stringRep ] + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure $ Map.lookup byteHex $ unwrap val where stringRep :: String stringRep = unsafePartial $ ScriptHash.toBech32Unsafe "script" $ unwrap skh @@ -86,10 +86,10 @@ getValidatorHashDelegationsAndRewards skh = do getPubKeyHashDelegationsAndRewards :: StakePubKeyHash -> QueryM (Maybe DelegationsAndRewards) getPubKeyHashDelegationsAndRewards pkh = do - DelegationsAndRewardsR mp <- mkOgmiosRequest Ogmios.queryDelegationsAndRewards - _.delegationsAndRewards - [ stringRep ] - pure $ Map.lookup byteHex mp + resp <- OgmiosHttp.delegationsAndRewards [ stringRep ] + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure $ Map.lookup byteHex $ unwrap val where stringRep :: String stringRep = unsafePartial diff --git a/src/Internal/ServerConfig.purs b/src/Internal/ServerConfig.purs index 8b42d91096..4e1479cf31 100644 --- a/src/Internal/ServerConfig.purs +++ b/src/Internal/ServerConfig.purs @@ -16,7 +16,7 @@ module Ctl.Internal.ServerConfig import Prelude import Ctl.Internal.Helpers ((<>)) -import Ctl.Internal.JsWebSocket (Url) +import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (Url) import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.UInt (UInt) import Data.UInt as UInt diff --git a/src/Internal/Test/E2E/Feedback/Browser.purs b/src/Internal/Test/E2E/Feedback/Browser.purs index 6b27bb98d2..64f3284d21 100644 --- a/src/Internal/Test/E2E/Feedback/Browser.purs +++ b/src/Internal/Test/E2E/Feedback/Browser.purs @@ -13,7 +13,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, jsonToAeson, stringifyAeson) import Ctl.Internal.FfiHelpers (MaybeFfiHelper, maybeFfiHelper) import Ctl.Internal.Helpers (liftedM) -import Ctl.Internal.QueryM (ClusterSetup) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent) import Data.Argonaut (Json) import Data.Either (hush) diff --git a/src/Internal/Test/E2E/Feedback/Node.purs b/src/Internal/Test/E2E/Feedback/Node.purs index e95eed1516..fcd1157abc 100644 --- a/src/Internal/Test/E2E/Feedback/Node.purs +++ b/src/Internal/Test/E2E/Feedback/Node.purs @@ -12,7 +12,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, parseJsonStringToAeson, stringifyAeson) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM (ClusterSetup) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent(Failure, Success)) import Data.Array as Array import Data.Either (Either(Left), hush, note) diff --git a/src/Internal/Test/E2E/Route.purs b/src/Internal/Test/E2E/Route.purs index 7988505105..2411aeec6d 100644 --- a/src/Internal/Test/E2E/Route.purs +++ b/src/Internal/Test/E2E/Route.purs @@ -25,7 +25,7 @@ import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftMaybe) import Ctl.Internal.Contract.ProviderBackend (mkCtlBackendParams) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM (ClusterSetup) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback.Browser (getClusterSetupRepeatedly) import Ctl.Internal.Test.E2E.Feedback.Hooks (addE2EFeedbackHooks) import Ctl.Internal.Wallet.Spec (WalletSpec(ConnectToGenericCip30)) diff --git a/src/Internal/Test/E2E/Runner.purs b/src/Internal/Test/E2E/Runner.purs index 81012a63fe..d38f769f91 100644 --- a/src/Internal/Test/E2E/Runner.purs +++ b/src/Internal/Test/E2E/Runner.purs @@ -24,7 +24,7 @@ import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Contract.Hooks (emptyHooks) import Ctl.Internal.Contract.ProviderBackend (ProviderBackend(CtlBackend)) import Ctl.Internal.Helpers (liftedM, unsafeFromJust, (<>)) -import Ctl.Internal.QueryM (ClusterSetup) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Browser (withBrowser) import Ctl.Internal.Test.E2E.Feedback ( BrowserEvent(ConfirmAccess, Sign, Success, Failure) diff --git a/test/Ogmios/Aeson.purs b/test/Ogmios/Aeson.purs index d3d06dc5f6..113e970b0d 100644 --- a/test/Ogmios/Aeson.purs +++ b/test/Ogmios/Aeson.purs @@ -7,7 +7,6 @@ import Prelude import Aeson (Aeson, JsonDecodeError, encodeAeson, printJsonDecodeError) import Aeson as Aeson -import Contract.Backend.Ogmios.Mempool (MempoolSizeAndCapacity) import Control.Monad.Error.Class (liftEither) import Control.Monad.Trans.Class (lift) import Control.Parallel (parTraverse) @@ -67,7 +66,7 @@ tested = , ("evaluateTransaction" /\ check (Proxy :: _ OgmiosTxEvaluationR)) , ("submitTransaction" /\ check (Proxy :: _ SubmitTxR)) , ("hasTransaction" /\ check (Proxy :: _ HasTxR)) - , ("sizeOfMempool" /\ check (Proxy :: _ MempoolSizeAndCapacity)) + , ("sizeOfMempool" /\ check (Proxy :: _ O.MempoolSizeAndCapacity)) -- ignoring because response may lack tx cbor if not run with flag -- This endpoint is tested with "fetchMempoolTXs" test (Test.Ctl.Plutip.Contract.OgmiosMempool) -- , ("nextTransaction" /\ (Proxy :: _ MaybeMempoolTransaction )) diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index f1ae3eca67..e41b8d3c77 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -7,7 +7,13 @@ import Prelude import Aeson (class EncodeAeson, Aeson, encodeAeson, stringifyAeson) import Control.Parallel (parTraverse) import Ctl.Internal.Helpers (logString) -import Ctl.Internal.JsWebSocket +import Ctl.Internal.QueryM.JsonRpc2 (class DecodeOgmios, JsonRpc2Call) +import Ctl.Internal.QueryM.Ogmios (mkOgmiosCallType) +import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher + ( WebsocketDispatch + , mkWebsocketDispatch + ) +import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket ( _mkWebSocket , _onWsConnect , _onWsError @@ -15,19 +21,18 @@ import Ctl.Internal.JsWebSocket , _wsClose , _wsSend ) -import Ctl.Internal.QueryM +import Ctl.Internal.QueryM.OgmiosWebsocket.Types ( ListenerSet , WebSocket(WebSocket) - , WebsocketDispatch , defaultMessageListener - , defaultOgmiosWsConfig , mkListenerSet , mkRequestAff - , mkWebsocketDispatch ) -import Ctl.Internal.QueryM.JsonRpc2 (class DecodeOgmios, JsonRpc2Call) -import Ctl.Internal.QueryM.Ogmios (mkOgmiosCallType) -import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) +import Ctl.Internal.ServerConfig + ( ServerConfig + , defaultOgmiosWsConfig + , mkWsUrl + ) import Data.Either (Either(Left, Right)) import Data.Log.Level (LogLevel(Trace, Debug)) import Data.Map as Map diff --git a/test/QueryM/AffInterface.purs b/test/QueryM/AffInterface.purs index 324410a747..281f9a4f52 100644 --- a/test/QueryM/AffInterface.purs +++ b/test/QueryM/AffInterface.purs @@ -5,9 +5,10 @@ import Prelude import Cardano.Serialization.Lib (fromBytes) import Contract.Transaction (TransactionHash(TransactionHash)) import Control.Monad.Except (throwError) -import Ctl.Internal.QueryM (QueryM, getChainTip, submitTxOgmios) +import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) +import Ctl.Internal.QueryM.OgmiosHttp (getChainTip, submitTxOgmios) import Data.ByteArray (hexToByteArrayUnsafe) import Data.Either (Either(Left, Right)) import Data.Maybe (fromJust, isJust) diff --git a/test/Testnet/Contract/OgmiosMempool.purs b/test/Testnet/Contract/OgmiosMempool.purs index 6edd6cb464..5a47a90c0a 100644 --- a/test/Testnet/Contract/OgmiosMempool.purs +++ b/test/Testnet/Contract/OgmiosMempool.purs @@ -6,8 +6,7 @@ import Prelude import Cardano.Types.BigNum as BigNum import Contract.Backend.Ogmios.Mempool - ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) - , acquireMempoolSnapshot + ( acquireMempoolSnapshot , fetchMempoolTxs , mempoolSnapshotHasTx , mempoolSnapshotSizeAndCapacity @@ -18,6 +17,9 @@ import Contract.Test (ContractTest, InitialUTxOs, withKeyWallet, withWallets) import Contract.Test.Mote (TestPlanM) import Contract.Transaction (awaitTxConfirmed) import Ctl.Examples.PlutusV2.InlineDatum as InlineDatum +import Ctl.Internal.QueryM.Ogmios + ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) + ) import Data.Array (length) import Mote (group, skip, test) import Test.Spec.Assertions (shouldEqual) From 14a6d9d5fb127cf498c376f85ad5cc30129a25a9 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 11:28:13 -0300 Subject: [PATCH 02/27] Remove mempool methods from `QueryM.Ogmios` --- src/Contract/Backend/Ogmios/Mempool.purs | 14 +- src/Internal/Contract/Monad.purs | 4 +- src/Internal/Contract/ProviderBackend.purs | 2 +- src/Internal/QueryM.purs | 4 +- src/Internal/QueryM/CurrentEpoch.purs | 2 +- src/Internal/QueryM/Ogmios.purs | 45 -- src/Internal/QueryM/OgmiosHttp.purs | 15 +- .../QueryM/OgmiosWebsocket/Mempool.purs | 543 ++++++++++++++++- .../QueryM/OgmiosWebsocket/Queries.purs | 2 +- .../QueryM/OgmiosWebsocket/Types.purs | 559 ------------------ test/Ogmios/GenerateFixtures.purs | 4 +- 11 files changed, 548 insertions(+), 646 deletions(-) delete mode 100644 src/Internal/QueryM/OgmiosWebsocket/Types.purs diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index b4c071e3ab..46fc959f57 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -27,20 +27,18 @@ import Ctl.Internal.QueryM.Ogmios ( MempoolSizeAndCapacity , MempoolSnapshotAcquired , MempoolTransaction(MempoolTransaction) - , acquireMempoolSnapshotCall ) as Ogmios import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (JsWebSocket) import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool - ( mempoolSnapshotHasTxCall - , mempoolSnapshotNextTxCall - , mempoolSnapshotSizeAndCapacityCall - , releaseMempoolCall - ) -import Ctl.Internal.QueryM.OgmiosWebsocket.Types ( ListenerSet , OgmiosListeners + , acquireMempoolSnapshotCall , listeners + , mempoolSnapshotHasTxCall + , mempoolSnapshotNextTxCall + , mempoolSnapshotSizeAndCapacityCall , mkRequestAff + , releaseMempoolCall , underlyingWebSocket ) import Data.Array as Array @@ -118,7 +116,7 @@ acquireMempoolSnapshotFetch :: QueryM Ogmios.MempoolSnapshotAcquired acquireMempoolSnapshotFetch = mkOgmiosRequest - Ogmios.acquireMempoolSnapshotCall + acquireMempoolSnapshotCall _.acquireMempool unit diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index 34185b3c18..d96c86cc4c 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -63,12 +63,12 @@ import Ctl.Internal.QueryM.OgmiosHttp , getSystemStartTime ) import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (_wsClose, _wsFinalize) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) -import Ctl.Internal.QueryM.OgmiosWebsocket.Types +import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool ( WebSocket , mkOgmiosWebSocketAff , underlyingWebSocket ) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM diff --git a/src/Internal/Contract/ProviderBackend.purs b/src/Internal/Contract/ProviderBackend.purs index 13139b4550..4bcfa8b86d 100644 --- a/src/Internal/Contract/ProviderBackend.purs +++ b/src/Internal/Contract/ProviderBackend.purs @@ -15,7 +15,7 @@ module Ctl.Internal.Contract.ProviderBackend import Prelude -import Ctl.Internal.QueryM.OgmiosWebsocket.Types (OgmiosWebSocket) +import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool (OgmiosWebSocket) import Ctl.Internal.ServerConfig (ServerConfig) import Data.Maybe (Maybe(Just, Nothing)) import Data.Time.Duration (Seconds(Seconds)) diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 2470fd7149..04241bbd01 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -33,12 +33,12 @@ import Ctl.Internal.Helpers (logWithLevel) import Ctl.Internal.Logging (mkLogger) import Ctl.Internal.QueryM.Ogmios (AdditionalUtxoSet, OgmiosTxEvaluationR) import Ctl.Internal.QueryM.Ogmios as Ogmios -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) -import Ctl.Internal.QueryM.OgmiosWebsocket.Types +import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool ( listeners , mkRequestAff , underlyingWebSocket ) +import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right)) import Data.Maybe (fromMaybe) diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index 527c50b1ad..d2c8958dcc 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -16,7 +16,7 @@ import Effect.Exception (error) -- | Get the current Epoch. Details can be found https://ogmios.dev/api/ under -- | "currentEpoch" query getCurrentEpoch :: QueryM CurrentEpoch -getCurrentEpoch = do +getCurrentEpoch = do resp <- OgmiosHttp.currentEpoch case resp of Left err -> throwError $ error $ pprintOgmiosDecodeError err diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 30fd3dc127..1db2fbc463 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -26,14 +26,7 @@ module Ctl.Internal.QueryM.Ogmios , OgmiosTxEvaluationR(OgmiosTxEvaluationR) , aesonObject , aesonArray - , acquireMempoolSnapshotCall , evaluateTxCall - , mempoolSnapshotHasTxCall - , mempoolSnapshotNextTxCall - , mempoolSnapshotSizeAndCapacityCall - , mkOgmiosCallType - , mkOgmiosCallTypeNoArgs - , releaseMempoolCall , submitSuccessPartialResp , parseIpv6String , rationalToSubcoin @@ -202,48 +195,10 @@ evaluateTxCall = mkOgmiosCallType } } --------------------------------------------------------------------------------- --- Local Tx Monitor Protocol --- https://ogmios.dev/mini-protocols/local-tx-monitor/ --------------------------------------------------------------------------------- - -acquireMempoolSnapshotCall :: JsonRpc2Call Unit MempoolSnapshotAcquired -acquireMempoolSnapshotCall = - mkOgmiosCallTypeNoArgs "acquireMempool" - -mempoolSnapshotHasTxCall - :: MempoolSnapshotAcquired -> JsonRpc2Call TransactionHash HasTxR -mempoolSnapshotHasTxCall _ = mkOgmiosCallType - { method: "hasTransaction" - , params: { id: _ } - } - -mempoolSnapshotNextTxCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit MaybeMempoolTransaction -mempoolSnapshotNextTxCall _ = mkOgmiosCallType - { method: "nextTransaction" - , params: const { fields: "all" } - } - -mempoolSnapshotSizeAndCapacityCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityCall _ = - mkOgmiosCallTypeNoArgs "sizeOfMempool" - -releaseMempoolCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool -releaseMempoolCall _ = - mkOgmiosCallTypeNoArgs "releaseMempool" - -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- -mkOgmiosCallTypeNoArgs - :: forall (o :: Type). DecodeOgmios o => String -> JsonRpc2Call Unit o -mkOgmiosCallTypeNoArgs method = - mkOgmiosCallType { method, params: const {} } - mkOgmiosCallType :: forall (a :: Type) (i :: Type) (o :: Type) . EncodeAeson (JsonRpc2Request a) diff --git a/src/Internal/QueryM/OgmiosHttp.purs b/src/Internal/QueryM/OgmiosHttp.purs index ecdb67f70a..ad0da2c946 100644 --- a/src/Internal/QueryM/OgmiosHttp.purs +++ b/src/Internal/QueryM/OgmiosHttp.purs @@ -39,7 +39,10 @@ import Affjax.ResponseFormat (string) as Affjax.ResponseFormat import Affjax.StatusCode (StatusCode(StatusCode)) import Affjax.StatusCode as Affjax.StatusCode import Cardano.AsCbor (encodeCbor) -import Cardano.Provider.Error (ClientError(..), ServiceError(..)) +import Cardano.Provider.Error + ( ClientError(ClientHttpError, ClientHttpResponseError) + , ServiceError(ServiceOtherError) + ) import Cardano.Provider.TxEvaluation as Provider import Cardano.Serialization.Lib (fromBytes) import Cardano.Types @@ -56,10 +59,10 @@ import Cardano.Types.Chain as Chain import Cardano.Types.Coin (Coin(Coin)) import Cardano.Types.CostModel (CostModel(CostModel)) import Cardano.Types.EraSummaries - ( EraSummaries(..) - , EraSummary(..) - , EraSummaryParameters(..) - , EraSummaryTime(..) + ( EraSummaries(EraSummaries) + , EraSummary(EraSummary) + , EraSummaryParameters(EraSummaryParameters) + , EraSummaryTime(EraSummaryTime) ) import Cardano.Types.ExUnitPrices (ExUnitPrices(ExUnitPrices)) import Cardano.Types.ExUnits (ExUnits(ExUnits)) @@ -93,7 +96,7 @@ import Ctl.Internal.Helpers (encodeMap, showWithParens) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 ( class DecodeOgmios - , OgmiosDecodeError(..) + , OgmiosDecodeError(ClientErrorResponse, ResultDecodingError) , OgmiosError , decodeErrorOrResult , decodeOgmios diff --git a/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs b/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs index c377ad651e..ca9268b7f0 100644 --- a/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs +++ b/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs @@ -9,40 +9,114 @@ module Ctl.Internal.QueryM.OgmiosWebsocket.Mempool , mempoolSnapshotNextTxCall , mempoolSnapshotSizeAndCapacityCall , releaseMempoolCall + , ListenerSet + , OgmiosListeners + , mkOgmiosCallType + , OgmiosWebSocket + , SubmitTxListenerSet + , WebSocket(WebSocket) + , listeners + , mkListenerSet + , defaultMessageListener + , mkOgmiosRequestAff + , mkOgmiosWebSocketAff + , mkRequestAff + , underlyingWebSocket + , mkOgmiosWebSocketLens + , mkSubmitTxListenerSet + , MkServiceWebSocketLens ) where import Prelude -import Aeson (class EncodeAeson) +import Aeson + ( class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch) + , encodeAeson + , parseJsonStringToAeson + , stringifyAeson + ) +import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.TransactionHash (TransactionHash) +import Control.Monad.Error.Class (liftEither, throwError) import Ctl.Internal.Logging (Logger) import Ctl.Internal.QueryM.JsonRpc2 ( class DecodeOgmios , JsonRpc2Call , JsonRpc2Request + , OgmiosDecodeError + , decodeOgmios , mkCallType + , ogmiosDecodeErrorToError ) +import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios - ( HasTxR + ( AdditionalUtxoSet + , DelegationsAndRewardsR + , HasTxR + , MaybeMempoolTransaction + , OgmiosProtocolParameters + , OgmiosTxEvaluationR + , PoolParametersR + , ReleasedMempool + , StakePoolsQueryArgument + ) +import Ctl.Internal.QueryM.Ogmios + ( ChainTipQR + , CurrentEpoch + , HasTxR , MaybeMempoolTransaction , MempoolSizeAndCapacity , MempoolSnapshotAcquired , MempoolTransaction + , OgmiosEraSummaries + , OgmiosSystemStart , ReleasedMempool - , acquireMempoolSnapshotCall - , mempoolSnapshotHasTxCall - , mempoolSnapshotNextTxCall - , mempoolSnapshotSizeAndCapacityCall - , releaseMempoolCall + , SubmitTxR + , submitSuccessPartialResp ) as Ogmios -import Ctl.Internal.QueryM.Ogmios (ReleasedMempool) -import Ctl.Internal.QueryM.OgmiosWebsocket.Types - ( OgmiosWebSocket - , mkOgmiosRequestAff +import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher + ( DispatchError(JsonError) + , Dispatcher + , GenericPendingRequests + , PendingRequests + , PendingSubmitTxRequests + , RequestBody + , WebsocketDispatch + , mkWebsocketDispatch + , newDispatcher + , newPendingRequests ) -import Data.Maybe (Maybe) -import Data.Newtype (unwrap) -import Effect.Aff (Aff) +import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket + ( JsWebSocket + , Url + , _mkWebSocket + , _onWsConnect + , _onWsError + , _onWsMessage + , _removeOnWsError + , _wsClose + , _wsFinalize + , _wsSend + ) +import Ctl.Internal.QueryM.UniqueId (ListenerId) +import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) +import Data.Bifunctor (lmap) +import Data.Either (Either(Left, Right), either, isRight) +import Data.Foldable (foldl) +import Data.Log.Level (LogLevel(Error, Debug)) +import Data.Map as Map +import Data.Maybe (Maybe(Just, Nothing), maybe) +import Data.Newtype (unwrap, wrap) +import Data.Traversable (for_, traverse_) +import Data.Tuple (fst) +import Data.Tuple.Nested (type (/\), (/\)) +import Effect (Effect) +import Effect.Aff (Aff, Canceler(Canceler), delay, launchAff_, makeAff, runAff_) +import Effect.Class (liftEffect) +import Effect.Exception (Error, error) +import Effect.Ref as Ref -------------------------------------------------------------------------------- -- Ogmios Local Tx Monitor Protocol @@ -51,7 +125,7 @@ import Effect.Aff (Aff) acquireMempoolSnapshotAff :: OgmiosWebSocket -> Logger -> Aff Ogmios.MempoolSnapshotAcquired acquireMempoolSnapshotAff ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger Ogmios.acquireMempoolSnapshotCall + mkOgmiosRequestAff ogmiosWs logger acquireMempoolSnapshotCall _.acquireMempool unit @@ -63,7 +137,7 @@ mempoolSnapshotHasTxAff -> Aff Boolean mempoolSnapshotHasTxAff ogmiosWs logger ms txh = unwrap <$> mkOgmiosRequestAff ogmiosWs logger - (Ogmios.mempoolSnapshotHasTxCall ms) + (mempoolSnapshotHasTxCall ms) _.mempoolHasTx txh @@ -74,7 +148,7 @@ mempoolSnapshotSizeAndCapacityAff -> Aff Ogmios.MempoolSizeAndCapacity mempoolSnapshotSizeAndCapacityAff ogmiosWs logger ms = mkOgmiosRequestAff ogmiosWs logger - (Ogmios.mempoolSnapshotSizeAndCapacityCall ms) + (mempoolSnapshotSizeAndCapacityCall ms) _.mempoolSizeAndCapacity -- todo: typo unit @@ -84,7 +158,7 @@ releaseMempoolAff -> Ogmios.MempoolSnapshotAcquired -> Aff ReleasedMempool releaseMempoolAff ogmiosWs logger ms = - mkOgmiosRequestAff ogmiosWs logger (Ogmios.releaseMempoolCall ms) + mkOgmiosRequestAff ogmiosWs logger (releaseMempoolCall ms) _.releaseMempool unit @@ -94,7 +168,7 @@ mempoolSnapshotNextTxAff -> Ogmios.MempoolSnapshotAcquired -> Aff (Maybe Ogmios.MempoolTransaction) mempoolSnapshotNextTxAff ogmiosWs logger ms = unwrap <$> - mkOgmiosRequestAff ogmiosWs logger (Ogmios.mempoolSnapshotNextTxCall ms) + mkOgmiosRequestAff ogmiosWs logger (mempoolSnapshotNextTxCall ms) _.mempoolNextTx unit @@ -129,6 +203,20 @@ releaseMempoolCall releaseMempoolCall _ = mkOgmiosCallTypeNoArgs "releaseMempool" +withMempoolSnapshot + :: OgmiosWebSocket + -> Logger + -> (Maybe Ogmios.MempoolSnapshotAcquired -> Aff Unit) + -> Effect Unit +withMempoolSnapshot ogmiosWs logger cont = + flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of + Left err -> do + logger Error $ + "Failed to acquire a mempool snapshot: Error: " <> show err + launchAff_ (cont Nothing) + Right mempoolSnapshot -> + launchAff_ (cont $ Just mempoolSnapshot) + -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- @@ -146,3 +234,420 @@ mkOgmiosCallType -> JsonRpc2Call i o mkOgmiosCallType = mkCallType { jsonrpc: "2.0" } + +-------------------------------------------------------------------------------- +-- WebSocket +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- Type-safe `WebSocket` +-------------------------------------------------------------------------------- + +-- don't export this constructor +-- type-safe websocket which has automated req/res dispatch and websocket +-- failure handling +data WebSocket listeners = WebSocket JsWebSocket listeners +type OgmiosWebSocket = WebSocket OgmiosListeners + +-- getter +underlyingWebSocket :: forall (a :: Type). WebSocket a -> JsWebSocket +underlyingWebSocket (WebSocket ws _) = ws + +-- getter +listeners :: forall (listeners :: Type). WebSocket listeners -> listeners +listeners (WebSocket _ ls) = ls + +-------------------------------------------------------------------------------- +-- OgmiosWebSocket Setup and PrimOps +-------------------------------------------------------------------------------- + +type IsTxConfirmed = TransactionHash -> Aff Boolean + +mkOgmiosWebSocketAff + :: IsTxConfirmed + -> Logger + -> ServerConfig + -> Aff OgmiosWebSocket +mkOgmiosWebSocketAff isTxConfirmed logger serverConfig = do + lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed + makeAff $ mkServiceWebSocket lens (mkWsUrl serverConfig) + +mkServiceWebSocket + :: forall (listeners :: Type) + . MkServiceWebSocketLens listeners + -> Url + -> (Either Error (WebSocket listeners) -> Effect Unit) + -> Effect Canceler +mkServiceWebSocket lens url continue = do + ws <- _mkWebSocket (lens.logger Debug) url + let + messageDispatch :: WebsocketDispatch + messageDispatch = mkWebsocketDispatch lens.dispatcher + + -- We want to fail if the first connection attempt is not successful. + -- Otherwise, we start reconnecting indefinitely. + onFirstConnectionError :: String -> Effect Unit + onFirstConnectionError errMessage = do + _wsFinalize ws + _wsClose ws + lens.logger Error $ + "First connection to " <> lens.serviceName <> " WebSocket failed. " + <> "Terminating. Error: " + <> errMessage + continue $ Left $ error errMessage + firstConnectionErrorRef <- _onWsError ws onFirstConnectionError + hasConnectedOnceRef <- Ref.new false + _onWsConnect ws $ Ref.read hasConnectedOnceRef >>= case _ of + true -> do + lens.logger Debug $ + lens.serviceName <> + " WebSocket connection re-established, resending pending requests..." + lens.resendPendingRequests ws + false -> do + lens.logger Debug $ "Connection to " <> lens.serviceName <> " established" + Ref.write true hasConnectedOnceRef + _removeOnWsError ws firstConnectionErrorRef + _onWsMessage ws (lens.logger Debug) $ defaultMessageListener lens.logger + [ messageDispatch ] + void $ _onWsError ws \err -> do + lens.logger Debug $ + lens.serviceName <> " WebSocket error (" <> err <> + "). Reconnecting..." + continue $ Right (lens.typedWebSocket ws) + pure $ Canceler $ \err -> liftEffect do + _wsFinalize ws + _wsClose ws + continue $ Left $ err + +-------------------------------------------------------------------------------- +-- Resend pending `SubmitTx` requests +-------------------------------------------------------------------------------- + +-- | For each pending `SubmitTx` request, checks whether the transaction has +-- | been added to the mempool or has been included in a block before retrying +-- | the request. +resendPendingSubmitRequests + :: OgmiosWebSocket + -> IsTxConfirmed + -> Logger + -> (RequestBody -> Effect Unit) + -> Dispatcher + -> PendingSubmitTxRequests + -> Effect Unit +resendPendingSubmitRequests + ogmiosWs + isTxConfirmed + logger + sendRequest + dispatcher + pr = do + submitTxPendingRequests <- Ref.read pr + unless (Map.isEmpty submitTxPendingRequests) do + -- Acquiring a mempool snapshot should never fail and, + -- after ws reconnection, should be instantaneous. + withMempoolSnapshot ogmiosWs logger case _ of + Nothing -> + liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests + Just ms -> do + -- A delay of 5 sec for transactions to be processed by the node + -- and added to the mempool: + delay (wrap 5000.0) + let (pr' :: Array _) = Map.toUnfoldable submitTxPendingRequests + for_ pr' \(listenerId /\ requestBody /\ txHash) -> + handlePendingSubmitRequest ms listenerId requestBody txHash + where + log :: String -> Boolean -> TransactionHash -> Aff Unit + log label value txHash = + liftEffect $ logger Debug $ + label <> ": " <> show value <> " TransactionHash: " <> show txHash + + handlePendingSubmitRequest + :: Ogmios.MempoolSnapshotAcquired + -> ListenerId + -> RequestBody + -> TransactionHash + -> Aff Unit + handlePendingSubmitRequest ms listenerId requestBody txHash = do + -- Check if the transaction was added to the mempool: + txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash + log "Tx in the mempool" txInMempool txHash + retrySubmitTx <- + if txInMempool then pure false + else do + -- Check if the transaction was included in the block: + txConfirmed <- isTxConfirmed txHash + log "Tx confirmed" txConfirmed txHash + unless txConfirmed $ liftEffect do + sendRequest requestBody + pure (not txConfirmed) + -- Manually dispatch `SubmitTx` response if resending is not required: + unless retrySubmitTx $ liftEffect do + Ref.modify_ (Map.delete listenerId) pr + dispatchMap <- Ref.read dispatcher + Ref.modify_ (Map.delete listenerId) dispatcher + Map.lookup listenerId dispatchMap # + maybe (pure unit) (_ $ submitSuccessPartialResp) + where + submitSuccessPartialResp :: Aeson + submitSuccessPartialResp = + encodeAeson $ Ogmios.submitSuccessPartialResp txHash + +-------------------------------------------------------------------------------- +-- `MkServiceWebSocketLens` for ogmios +-------------------------------------------------------------------------------- + +type MkServiceWebSocketLens (listeners :: Type) = + { serviceName :: String + , dispatcher :: Dispatcher + , logger :: Logger + , typedWebSocket :: JsWebSocket -> WebSocket listeners + , resendPendingRequests :: JsWebSocket -> Effect Unit + } + +mkOgmiosWebSocketLens + :: Logger + -> IsTxConfirmed + -> Effect (MkServiceWebSocketLens OgmiosListeners) +mkOgmiosWebSocketLens logger isTxConfirmed = do + dispatcher <- newDispatcher + pendingRequests <- newPendingRequests + pendingSubmitTxRequests <- newPendingRequests + pure $ + let + ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket + ogmiosWebSocket ws = WebSocket ws + { chainTip: + mkListenerSet dispatcher pendingRequests + , evaluate: + mkListenerSet dispatcher pendingRequests + , getProtocolParameters: + mkListenerSet dispatcher pendingRequests + , eraSummaries: + mkListenerSet dispatcher pendingRequests + , currentEpoch: + mkListenerSet dispatcher pendingRequests + , systemStart: + mkListenerSet dispatcher pendingRequests + , acquireMempool: + mkListenerSet dispatcher pendingRequests + , releaseMempool: + mkListenerSet dispatcher pendingRequests + , mempoolHasTx: + mkListenerSet dispatcher pendingRequests + , mempoolNextTx: + mkListenerSet dispatcher pendingRequests + , mempoolSizeAndCapacity: + mkListenerSet dispatcher pendingRequests + , submit: + mkSubmitTxListenerSet dispatcher pendingSubmitTxRequests + , stakePools: + mkListenerSet dispatcher pendingRequests + , delegationsAndRewards: + mkListenerSet dispatcher pendingRequests + } + + resendPendingRequests :: JsWebSocket -> Effect Unit + resendPendingRequests ws = do + let sendRequest = _wsSend ws (logger Debug) + Ref.read pendingRequests >>= traverse_ sendRequest + resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed + logger + sendRequest + dispatcher + pendingSubmitTxRequests + in + { serviceName: "ogmios" + , dispatcher + , logger + , typedWebSocket: ogmiosWebSocket + , resendPendingRequests + } + +-------------------------------------------------------------------------------- +-- ListenerSet +-------------------------------------------------------------------------------- + +type OgmiosListeners = + { chainTip :: ListenerSet Unit Ogmios.ChainTipQR + , submit :: SubmitTxListenerSet + , evaluate :: + ListenerSet (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR + , getProtocolParameters :: ListenerSet Unit OgmiosProtocolParameters + , eraSummaries :: ListenerSet Unit Ogmios.OgmiosEraSummaries + , currentEpoch :: ListenerSet Unit Ogmios.CurrentEpoch + , systemStart :: ListenerSet Unit Ogmios.OgmiosSystemStart + , acquireMempool :: ListenerSet Unit Ogmios.MempoolSnapshotAcquired + , releaseMempool :: ListenerSet Unit ReleasedMempool + , mempoolHasTx :: ListenerSet TransactionHash HasTxR + , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction + , mempoolSizeAndCapacity :: ListenerSet Unit Ogmios.MempoolSizeAndCapacity + , stakePools :: ListenerSet StakePoolsQueryArgument PoolParametersR + , delegationsAndRewards :: ListenerSet (Array String) DelegationsAndRewardsR + } + +-- convenience type for adding additional query types later +type ListenerSet (request :: Type) (response :: Type) = + { addMessageListener :: + ListenerId + -> (Either OgmiosDecodeError response -> Effect Unit) + -> Effect Unit + , removeMessageListener :: ListenerId -> Effect Unit + -- ^ Removes ID from dispatch map and pending requests queue. + , addRequest :: ListenerId -> RequestBody /\ request -> Effect Unit + -- ^ Saves request body until the request is fulfilled. The body is used + -- to replay requests in case of a WebSocket failure. + } + +type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) + Ogmios.SubmitTxR + +mkAddMessageListener + :: forall (response :: Type) + . JsonRpc2.DecodeOgmios response + => Dispatcher + -> ( ListenerId + -> (Either JsonRpc2.OgmiosDecodeError response -> Effect Unit) + -> Effect Unit + ) +mkAddMessageListener dispatcher = + \reflection handler -> + flip Ref.modify_ dispatcher $ + Map.insert reflection + (\aeson -> handler $ decodeOgmios aeson) + +mkRemoveMessageListener + :: forall (requestData :: Type) + . Dispatcher + -> GenericPendingRequests requestData + -> (ListenerId -> Effect Unit) +mkRemoveMessageListener dispatcher pendingRequests = + \reflection -> do + Ref.modify_ (Map.delete reflection) dispatcher + Ref.modify_ (Map.delete reflection) pendingRequests + +-- we manipluate closures to make the DispatchIdMap updateable using these +-- methods, this can be picked up by a query or cancellation function +mkListenerSet + :: forall (request :: Type) (response :: Type) + . JsonRpc2.DecodeOgmios response + => Dispatcher + -> PendingRequests + -> ListenerSet request response +mkListenerSet dispatcher pendingRequests = + { addMessageListener: + mkAddMessageListener dispatcher + , removeMessageListener: + mkRemoveMessageListener dispatcher pendingRequests + , addRequest: + \reflection (requestBody /\ _) -> + Ref.modify_ (Map.insert reflection requestBody) pendingRequests + } + +mkSubmitTxListenerSet + :: Dispatcher -> PendingSubmitTxRequests -> SubmitTxListenerSet +mkSubmitTxListenerSet dispatcher pendingRequests = + { addMessageListener: + mkAddMessageListener dispatcher + , removeMessageListener: + mkRemoveMessageListener dispatcher pendingRequests + , addRequest: + \reflection (requestBody /\ txHash /\ _) -> + Ref.modify_ (Map.insert reflection (requestBody /\ txHash)) + pendingRequests + } + +-- | Builds an Ogmios request action using `Aff` +mkOgmiosRequestAff + :: forall (request :: Type) (response :: Type) + . OgmiosWebSocket + -> Logger + -> JsonRpc2.JsonRpc2Call request response + -> (OgmiosListeners -> ListenerSet request response) + -> request + -> Aff response +mkOgmiosRequestAff ogmiosWs = mkRequestAff + (listeners ogmiosWs) + (underlyingWebSocket ogmiosWs) + +mkRequestAff + :: forall (request :: Type) (response :: Type) (listeners :: Type) + . listeners + -> JsWebSocket + -> Logger + -> JsonRpc2.JsonRpc2Call request response + -> (listeners -> ListenerSet request response) + -> request + -> Aff response +mkRequestAff listeners' webSocket logger jsonRpc2Call getLs input = do + { body, id } <- + liftEffect $ JsonRpc2.buildRequest jsonRpc2Call input + let + respLs :: ListenerSet request response + respLs = getLs listeners' + + sBody :: RequestBody + sBody = stringifyAeson body + + affFunc :: (Either Error response -> Effect Unit) -> Effect Canceler + affFunc cont = do + _ <- respLs.addMessageListener id + ( \res -> do + respLs.removeMessageListener id + cont $ lmap ogmiosDecodeErrorToError res + ) + respLs.addRequest id (sBody /\ input) + _wsSend webSocket (logger Debug) sBody + -- Uncomment this code fragment to test `SubmitTx` request resend logic: + -- let method = aesonObject (flip getFieldOptional "methodname") body + -- when (method == Right (Just "SubmitTx")) do + -- _wsReconnect webSocket + pure $ Canceler $ \err -> do + liftEffect $ respLs.removeMessageListener id + liftEffect $ throwError $ err + makeAff affFunc + +-- an empty error we can compare to, useful for ensuring we've not received any other kind of error +defaultErr :: JsonDecodeError +defaultErr = TypeMismatch "default error" + +defaultMessageListener + :: Logger + -> Array WebsocketDispatch + -> String + -> Effect Unit +defaultMessageListener logger dispatchArray msg = do + aeson <- liftEither $ lmap (const $ error "Unable to parse response") $ + parseJsonStringToAeson msg + -- here, we need to fold the input over the array of functions until we get + -- a success, then execute the effect. + -- using a fold instead of a traverse allows us to skip a bunch of execution + eAction :: Either DispatchError (Effect Unit) <- foldl + (messageFoldF aeson) + (pure $ Left $ JsonError defaultErr) + dispatchArray + either + -- we expect a lot of parse errors, some messages (could?) fall through completely + ( \err -> + unless + ( case err of + JsonError jsonErr -> jsonErr == defaultErr + _ -> false + ) + do + logger Error $ + "unexpected error on input: " <> msg + <> " Error:" + <> show err + ) + identity + eAction + +messageFoldF + :: Aeson + -> Effect (Either DispatchError (Effect Unit)) + -> (Aeson -> (Effect (Either DispatchError (Effect Unit)))) + -> Effect (Either DispatchError (Effect Unit)) +messageFoldF msg acc' func = do + acc <- acc' + if isRight acc then acc' else func msg + diff --git a/src/Internal/QueryM/OgmiosWebsocket/Queries.purs b/src/Internal/QueryM/OgmiosWebsocket/Queries.purs index 3fd4b3cb99..84887fb12c 100644 --- a/src/Internal/QueryM/OgmiosWebsocket/Queries.purs +++ b/src/Internal/QueryM/OgmiosWebsocket/Queries.purs @@ -23,7 +23,7 @@ import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher , newDispatcher , newPendingRequests ) as ExportDispatcher -import Ctl.Internal.QueryM.OgmiosWebsocket.Types (OgmiosWebSocket) +import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool (OgmiosWebSocket) import Ctl.Internal.ServerConfig ( Host , ServerConfig diff --git a/src/Internal/QueryM/OgmiosWebsocket/Types.purs b/src/Internal/QueryM/OgmiosWebsocket/Types.purs deleted file mode 100644 index f3bab24c08..0000000000 --- a/src/Internal/QueryM/OgmiosWebsocket/Types.purs +++ /dev/null @@ -1,559 +0,0 @@ -module Ctl.Internal.QueryM.OgmiosWebsocket.Types - ( module ExportDispatcher - , module ExportServerConfig - , ListenerSet - , OgmiosListeners - , OgmiosWebSocket - , SubmitTxListenerSet - , WebSocket(WebSocket) - , listeners - , mkListenerSet - , defaultMessageListener - , mkOgmiosRequestAff - , mkOgmiosWebSocketAff - , mkRequestAff - , underlyingWebSocket - , mkOgmiosWebSocketLens - , mkSubmitTxListenerSet - , MkServiceWebSocketLens - ) where - -import Prelude - -import Aeson - ( Aeson - , JsonDecodeError(TypeMismatch) - , encodeAeson - , parseJsonStringToAeson - , stringifyAeson - ) -import Cardano.Types.CborBytes (CborBytes) -import Cardano.Types.TransactionHash (TransactionHash) -import Control.Monad.Error.Class (liftEither, throwError) -import Ctl.Internal.Logging (Logger) -import Ctl.Internal.QueryM.JsonRpc2 - ( OgmiosDecodeError - , decodeOgmios - , ogmiosDecodeErrorToError - ) -import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 -import Ctl.Internal.QueryM.Ogmios - ( AdditionalUtxoSet - , DelegationsAndRewardsR - , HasTxR - , MaybeMempoolTransaction - , OgmiosProtocolParameters - , OgmiosTxEvaluationR - , PoolParametersR - , ReleasedMempool - , StakePoolsQueryArgument - ) -import Ctl.Internal.QueryM.Ogmios as Ogmios -import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher - ( DispatchError(JsonError) - , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests - , RequestBody - , WebsocketDispatch - , mkWebsocketDispatch - , newDispatcher - , newPendingRequests - ) -import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher - ( DispatchError(JsonError, FaultError, ListenerCancelled) - , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests - , RequestBody - , WebsocketDispatch - , dispatchErrorToError - , mkWebsocketDispatch - , newDispatcher - , newPendingRequests - ) as ExportDispatcher -import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket - ( JsWebSocket - , Url - , _mkWebSocket - , _onWsConnect - , _onWsError - , _onWsMessage - , _removeOnWsError - , _wsClose - , _wsFinalize - , _wsSend - ) -import Ctl.Internal.QueryM.UniqueId (ListenerId) -import Ctl.Internal.ServerConfig - ( Host - , ServerConfig - , defaultOgmiosWsConfig - , mkHttpUrl - , mkServerUrl - , mkWsUrl - ) as ExportServerConfig -import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) -import Data.Bifunctor (lmap) -import Data.Either (Either(Left, Right), either, isRight) -import Data.Foldable (foldl) -import Data.Log.Level (LogLevel(Error, Debug)) -import Data.Map as Map -import Data.Maybe (Maybe(Just, Nothing), maybe) -import Data.Newtype (unwrap, wrap) -import Data.Traversable (for_, traverse_) -import Data.Tuple (fst) -import Data.Tuple.Nested (type (/\), (/\)) -import Effect (Effect) -import Effect.Aff (Aff, Canceler(Canceler), delay, launchAff_, makeAff, runAff_) -import Effect.Class (liftEffect) -import Effect.Exception (Error, error) -import Effect.Ref as Ref - -mempoolSnapshotHasTxAff - :: OgmiosWebSocket - -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> TransactionHash - -> Aff Boolean -mempoolSnapshotHasTxAff ogmiosWs logger ms txh = - unwrap <$> mkOgmiosRequestAff ogmiosWs logger - (Ogmios.mempoolSnapshotHasTxCall ms) - _.mempoolHasTx - txh - -acquireMempoolSnapshotAff - :: OgmiosWebSocket -> Logger -> Aff Ogmios.MempoolSnapshotAcquired -acquireMempoolSnapshotAff ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger Ogmios.acquireMempoolSnapshotCall - _.acquireMempool - unit - -withMempoolSnapshot - :: OgmiosWebSocket - -> Logger - -> (Maybe Ogmios.MempoolSnapshotAcquired -> Aff Unit) - -> Effect Unit -withMempoolSnapshot ogmiosWs logger cont = - flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of - Left err -> do - logger Error $ - "Failed to acquire a mempool snapshot: Error: " <> show err - launchAff_ (cont Nothing) - Right mempoolSnapshot -> - launchAff_ (cont $ Just mempoolSnapshot) - --------------------------------------------------------------------------------- --- Type-safe `WebSocket` --------------------------------------------------------------------------------- - --- don't export this constructor --- type-safe websocket which has automated req/res dispatch and websocket --- failure handling -data WebSocket listeners = WebSocket JsWebSocket listeners -type OgmiosWebSocket = WebSocket OgmiosListeners - --- getter -underlyingWebSocket :: forall (a :: Type). WebSocket a -> JsWebSocket -underlyingWebSocket (WebSocket ws _) = ws - --- getter -listeners :: forall (listeners :: Type). WebSocket listeners -> listeners -listeners (WebSocket _ ls) = ls - --------------------------------------------------------------------------------- --- OgmiosWebSocket Setup and PrimOps --------------------------------------------------------------------------------- - -type IsTxConfirmed = TransactionHash -> Aff Boolean - -mkOgmiosWebSocketAff - :: IsTxConfirmed - -> Logger - -> ServerConfig - -> Aff OgmiosWebSocket -mkOgmiosWebSocketAff isTxConfirmed logger serverConfig = do - lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed - makeAff $ mkServiceWebSocket lens (mkWsUrl serverConfig) - -mkServiceWebSocket - :: forall (listeners :: Type) - . MkServiceWebSocketLens listeners - -> Url - -> (Either Error (WebSocket listeners) -> Effect Unit) - -> Effect Canceler -mkServiceWebSocket lens url continue = do - ws <- _mkWebSocket (lens.logger Debug) url - let - messageDispatch :: WebsocketDispatch - messageDispatch = mkWebsocketDispatch lens.dispatcher - - -- We want to fail if the first connection attempt is not successful. - -- Otherwise, we start reconnecting indefinitely. - onFirstConnectionError :: String -> Effect Unit - onFirstConnectionError errMessage = do - _wsFinalize ws - _wsClose ws - lens.logger Error $ - "First connection to " <> lens.serviceName <> " WebSocket failed. " - <> "Terminating. Error: " - <> errMessage - continue $ Left $ error errMessage - firstConnectionErrorRef <- _onWsError ws onFirstConnectionError - hasConnectedOnceRef <- Ref.new false - _onWsConnect ws $ Ref.read hasConnectedOnceRef >>= case _ of - true -> do - lens.logger Debug $ - lens.serviceName <> - " WebSocket connection re-established, resending pending requests..." - lens.resendPendingRequests ws - false -> do - lens.logger Debug $ "Connection to " <> lens.serviceName <> " established" - Ref.write true hasConnectedOnceRef - _removeOnWsError ws firstConnectionErrorRef - _onWsMessage ws (lens.logger Debug) $ defaultMessageListener lens.logger - [ messageDispatch ] - void $ _onWsError ws \err -> do - lens.logger Debug $ - lens.serviceName <> " WebSocket error (" <> err <> - "). Reconnecting..." - continue $ Right (lens.typedWebSocket ws) - pure $ Canceler $ \err -> liftEffect do - _wsFinalize ws - _wsClose ws - continue $ Left $ err - --------------------------------------------------------------------------------- --- Resend pending `SubmitTx` requests --------------------------------------------------------------------------------- - --- | For each pending `SubmitTx` request, checks whether the transaction has --- | been added to the mempool or has been included in a block before retrying --- | the request. -resendPendingSubmitRequests - :: OgmiosWebSocket - -> IsTxConfirmed - -> Logger - -> (RequestBody -> Effect Unit) - -> Dispatcher - -> PendingSubmitTxRequests - -> Effect Unit -resendPendingSubmitRequests - ogmiosWs - isTxConfirmed - logger - sendRequest - dispatcher - pr = do - submitTxPendingRequests <- Ref.read pr - unless (Map.isEmpty submitTxPendingRequests) do - -- Acquiring a mempool snapshot should never fail and, - -- after ws reconnection, should be instantaneous. - withMempoolSnapshot ogmiosWs logger case _ of - Nothing -> - liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests - Just ms -> do - -- A delay of 5 sec for transactions to be processed by the node - -- and added to the mempool: - delay (wrap 5000.0) - let (pr' :: Array _) = Map.toUnfoldable submitTxPendingRequests - for_ pr' \(listenerId /\ requestBody /\ txHash) -> - handlePendingSubmitRequest ms listenerId requestBody txHash - where - log :: String -> Boolean -> TransactionHash -> Aff Unit - log label value txHash = - liftEffect $ logger Debug $ - label <> ": " <> show value <> " TransactionHash: " <> show txHash - - handlePendingSubmitRequest - :: Ogmios.MempoolSnapshotAcquired - -> ListenerId - -> RequestBody - -> TransactionHash - -> Aff Unit - handlePendingSubmitRequest ms listenerId requestBody txHash = do - -- Check if the transaction was added to the mempool: - txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash - log "Tx in the mempool" txInMempool txHash - retrySubmitTx <- - if txInMempool then pure false - else do - -- Check if the transaction was included in the block: - txConfirmed <- isTxConfirmed txHash - log "Tx confirmed" txConfirmed txHash - unless txConfirmed $ liftEffect do - sendRequest requestBody - pure (not txConfirmed) - -- Manually dispatch `SubmitTx` response if resending is not required: - unless retrySubmitTx $ liftEffect do - Ref.modify_ (Map.delete listenerId) pr - dispatchMap <- Ref.read dispatcher - Ref.modify_ (Map.delete listenerId) dispatcher - Map.lookup listenerId dispatchMap # - maybe (pure unit) (_ $ submitSuccessPartialResp) - where - submitSuccessPartialResp :: Aeson - submitSuccessPartialResp = - encodeAeson $ Ogmios.submitSuccessPartialResp txHash - --------------------------------------------------------------------------------- --- `MkServiceWebSocketLens` for ogmios --------------------------------------------------------------------------------- - -type MkServiceWebSocketLens (listeners :: Type) = - { serviceName :: String - , dispatcher :: Dispatcher - , logger :: Logger - , typedWebSocket :: JsWebSocket -> WebSocket listeners - , resendPendingRequests :: JsWebSocket -> Effect Unit - } - -mkOgmiosWebSocketLens - :: Logger - -> IsTxConfirmed - -> Effect (MkServiceWebSocketLens OgmiosListeners) -mkOgmiosWebSocketLens logger isTxConfirmed = do - dispatcher <- newDispatcher - pendingRequests <- newPendingRequests - pendingSubmitTxRequests <- newPendingRequests - pure $ - let - ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket - ogmiosWebSocket ws = WebSocket ws - { chainTip: - mkListenerSet dispatcher pendingRequests - , evaluate: - mkListenerSet dispatcher pendingRequests - , getProtocolParameters: - mkListenerSet dispatcher pendingRequests - , eraSummaries: - mkListenerSet dispatcher pendingRequests - , currentEpoch: - mkListenerSet dispatcher pendingRequests - , systemStart: - mkListenerSet dispatcher pendingRequests - , acquireMempool: - mkListenerSet dispatcher pendingRequests - , releaseMempool: - mkListenerSet dispatcher pendingRequests - , mempoolHasTx: - mkListenerSet dispatcher pendingRequests - , mempoolNextTx: - mkListenerSet dispatcher pendingRequests - , mempoolSizeAndCapacity: - mkListenerSet dispatcher pendingRequests - , submit: - mkSubmitTxListenerSet dispatcher pendingSubmitTxRequests - , stakePools: - mkListenerSet dispatcher pendingRequests - , delegationsAndRewards: - mkListenerSet dispatcher pendingRequests - } - - resendPendingRequests :: JsWebSocket -> Effect Unit - resendPendingRequests ws = do - let sendRequest = _wsSend ws (logger Debug) - Ref.read pendingRequests >>= traverse_ sendRequest - resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed - logger - sendRequest - dispatcher - pendingSubmitTxRequests - in - { serviceName: "ogmios" - , dispatcher - , logger - , typedWebSocket: ogmiosWebSocket - , resendPendingRequests - } - --------------------------------------------------------------------------------- --- ListenerSet --------------------------------------------------------------------------------- - -type OgmiosListeners = - { chainTip :: ListenerSet Unit Ogmios.ChainTipQR - , submit :: SubmitTxListenerSet - , evaluate :: - ListenerSet (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR - , getProtocolParameters :: ListenerSet Unit OgmiosProtocolParameters - , eraSummaries :: ListenerSet Unit Ogmios.OgmiosEraSummaries - , currentEpoch :: ListenerSet Unit Ogmios.CurrentEpoch - , systemStart :: ListenerSet Unit Ogmios.OgmiosSystemStart - , acquireMempool :: ListenerSet Unit Ogmios.MempoolSnapshotAcquired - , releaseMempool :: ListenerSet Unit ReleasedMempool - , mempoolHasTx :: ListenerSet TransactionHash HasTxR - , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction - , mempoolSizeAndCapacity :: ListenerSet Unit Ogmios.MempoolSizeAndCapacity - , stakePools :: ListenerSet StakePoolsQueryArgument PoolParametersR - , delegationsAndRewards :: ListenerSet (Array String) DelegationsAndRewardsR - } - --- convenience type for adding additional query types later -type ListenerSet (request :: Type) (response :: Type) = - { addMessageListener :: - ListenerId - -> (Either OgmiosDecodeError response -> Effect Unit) - -> Effect Unit - , removeMessageListener :: ListenerId -> Effect Unit - -- ^ Removes ID from dispatch map and pending requests queue. - , addRequest :: ListenerId -> RequestBody /\ request -> Effect Unit - -- ^ Saves request body until the request is fulfilled. The body is used - -- to replay requests in case of a WebSocket failure. - } - -type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) - Ogmios.SubmitTxR - -mkAddMessageListener - :: forall (response :: Type) - . JsonRpc2.DecodeOgmios response - => Dispatcher - -> ( ListenerId - -> (Either JsonRpc2.OgmiosDecodeError response -> Effect Unit) - -> Effect Unit - ) -mkAddMessageListener dispatcher = - \reflection handler -> - flip Ref.modify_ dispatcher $ - Map.insert reflection - (\aeson -> handler $ decodeOgmios aeson) - -mkRemoveMessageListener - :: forall (requestData :: Type) - . Dispatcher - -> GenericPendingRequests requestData - -> (ListenerId -> Effect Unit) -mkRemoveMessageListener dispatcher pendingRequests = - \reflection -> do - Ref.modify_ (Map.delete reflection) dispatcher - Ref.modify_ (Map.delete reflection) pendingRequests - --- we manipluate closures to make the DispatchIdMap updateable using these --- methods, this can be picked up by a query or cancellation function -mkListenerSet - :: forall (request :: Type) (response :: Type) - . JsonRpc2.DecodeOgmios response - => Dispatcher - -> PendingRequests - -> ListenerSet request response -mkListenerSet dispatcher pendingRequests = - { addMessageListener: - mkAddMessageListener dispatcher - , removeMessageListener: - mkRemoveMessageListener dispatcher pendingRequests - , addRequest: - \reflection (requestBody /\ _) -> - Ref.modify_ (Map.insert reflection requestBody) pendingRequests - } - -mkSubmitTxListenerSet - :: Dispatcher -> PendingSubmitTxRequests -> SubmitTxListenerSet -mkSubmitTxListenerSet dispatcher pendingRequests = - { addMessageListener: - mkAddMessageListener dispatcher - , removeMessageListener: - mkRemoveMessageListener dispatcher pendingRequests - , addRequest: - \reflection (requestBody /\ txHash /\ _) -> - Ref.modify_ (Map.insert reflection (requestBody /\ txHash)) - pendingRequests - } - --- | Builds an Ogmios request action using `Aff` -mkOgmiosRequestAff - :: forall (request :: Type) (response :: Type) - . OgmiosWebSocket - -> Logger - -> JsonRpc2.JsonRpc2Call request response - -> (OgmiosListeners -> ListenerSet request response) - -> request - -> Aff response -mkOgmiosRequestAff ogmiosWs = mkRequestAff - (listeners ogmiosWs) - (underlyingWebSocket ogmiosWs) - -mkRequestAff - :: forall (request :: Type) (response :: Type) (listeners :: Type) - . listeners - -> JsWebSocket - -> Logger - -> JsonRpc2.JsonRpc2Call request response - -> (listeners -> ListenerSet request response) - -> request - -> Aff response -mkRequestAff listeners' webSocket logger jsonRpc2Call getLs input = do - { body, id } <- - liftEffect $ JsonRpc2.buildRequest jsonRpc2Call input - let - respLs :: ListenerSet request response - respLs = getLs listeners' - - sBody :: RequestBody - sBody = stringifyAeson body - - affFunc :: (Either Error response -> Effect Unit) -> Effect Canceler - affFunc cont = do - _ <- respLs.addMessageListener id - ( \res -> do - respLs.removeMessageListener id - cont $ lmap ogmiosDecodeErrorToError res - ) - respLs.addRequest id (sBody /\ input) - _wsSend webSocket (logger Debug) sBody - -- Uncomment this code fragment to test `SubmitTx` request resend logic: - -- let method = aesonObject (flip getFieldOptional "methodname") body - -- when (method == Right (Just "SubmitTx")) do - -- _wsReconnect webSocket - pure $ Canceler $ \err -> do - liftEffect $ respLs.removeMessageListener id - liftEffect $ throwError $ err - makeAff affFunc - --- an empty error we can compare to, useful for ensuring we've not received any other kind of error -defaultErr :: JsonDecodeError -defaultErr = TypeMismatch "default error" - -defaultMessageListener - :: Logger - -> Array WebsocketDispatch - -> String - -> Effect Unit -defaultMessageListener logger dispatchArray msg = do - aeson <- liftEither $ lmap (const $ error "Unable to parse response") $ - parseJsonStringToAeson msg - -- here, we need to fold the input over the array of functions until we get - -- a success, then execute the effect. - -- using a fold instead of a traverse allows us to skip a bunch of execution - eAction :: Either DispatchError (Effect Unit) <- foldl - (messageFoldF aeson) - (pure $ Left $ JsonError defaultErr) - dispatchArray - either - -- we expect a lot of parse errors, some messages (could?) fall through completely - ( \err -> - unless - ( case err of - JsonError jsonErr -> jsonErr == defaultErr - _ -> false - ) - do - logger Error $ - "unexpected error on input: " <> msg - <> " Error:" - <> show err - ) - identity - eAction - -messageFoldF - :: Aeson - -> Effect (Either DispatchError (Effect Unit)) - -> (Aeson -> (Effect (Either DispatchError (Effect Unit)))) - -> Effect (Either DispatchError (Effect Unit)) -messageFoldF msg acc' func = do - acc <- acc' - if isRight acc then acc' else func msg - diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index e41b8d3c77..e8e6c229e8 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -8,7 +8,6 @@ import Aeson (class EncodeAeson, Aeson, encodeAeson, stringifyAeson) import Control.Parallel (parTraverse) import Ctl.Internal.Helpers (logString) import Ctl.Internal.QueryM.JsonRpc2 (class DecodeOgmios, JsonRpc2Call) -import Ctl.Internal.QueryM.Ogmios (mkOgmiosCallType) import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher ( WebsocketDispatch , mkWebsocketDispatch @@ -21,11 +20,12 @@ import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket , _wsClose , _wsSend ) -import Ctl.Internal.QueryM.OgmiosWebsocket.Types +import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool ( ListenerSet , WebSocket(WebSocket) , defaultMessageListener , mkListenerSet + , mkOgmiosCallType , mkRequestAff ) import Ctl.Internal.ServerConfig From 12896f5c4b7e507be7845bcabf308d57d75607cc Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 11:37:03 -0300 Subject: [PATCH 03/27] Fix warning --- src/Internal/Contract/Monad.purs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index d96c86cc4c..146cd22475 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -331,9 +331,6 @@ getLedgerConstants params = case _ of -> BlockfrostServiceM a withErrorOnLeft = (=<<) (lmap (show >>> error) >>> liftEither) - logger :: Logger - logger = mkLogger params.logLevel params.customLogger - -- TODO: Should we respect `suppressLogs` here? blockfrostLogger :: Message -> Aff Unit blockfrostLogger = fromMaybe logWithLevel params.customLogger params.logLevel From 219f4971716b90ffa73c3d24fddf41d2b05b2d3d Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 11:52:45 -0300 Subject: [PATCH 04/27] Use HTTP version of `evaluateTx` --- src/Internal/Contract/Provider.purs | 8 ++--- src/Internal/QueryM.purs | 30 ----------------- src/Internal/QueryM/Ogmios.purs | 35 -------------------- src/Internal/QueryM/OgmiosHttp.purs | 50 +++++++++++++++-------------- 4 files changed, 30 insertions(+), 93 deletions(-) diff --git a/src/Internal/Contract/Provider.purs b/src/Internal/Contract/Provider.purs index b5e85f6e30..20dfd3525a 100644 --- a/src/Internal/Contract/Provider.purs +++ b/src/Internal/Contract/Provider.purs @@ -16,7 +16,6 @@ import Ctl.Internal.Contract.LogParams (LogParams) import Ctl.Internal.Contract.ProviderBackend (BlockfrostBackend, CtlBackend) import Ctl.Internal.Helpers (logWithLevel) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM (evaluateTxOgmios) as QueryM import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) as OgmiosHttp import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) as OgmiosHttp import Ctl.Internal.QueryM.Kupo @@ -30,7 +29,8 @@ import Ctl.Internal.QueryM.Kupo ) as Kupo import Ctl.Internal.QueryM.Ogmios (SubmitTxR(SubmitFail, SubmitTxSuccess)) import Ctl.Internal.QueryM.OgmiosHttp - ( getChainTip + ( evaluateTxOgmios + , getChainTip , submitTxOgmios ) as OgmiosHttp import Ctl.Internal.QueryM.Pools @@ -78,10 +78,10 @@ providerForCtlBackend runQueryM params backend = "Computed TransactionHash is not equal to the one returned by Ogmios, please report as bug!" ) SubmitFail err -> Left $ ClientOtherError $ show err - , evaluateTx: \tx additionalUtxos -> unwrap <$> + , evaluateTx: \tx additionalUtxos -> runQueryM' do let txBytes = encodeCbor tx - QueryM.evaluateTxOgmios txBytes (wrap additionalUtxos) + OgmiosHttp.evaluateTxOgmios txBytes (wrap additionalUtxos) , getEraSummaries: Right <$> runQueryM' OgmiosHttp.getEraSummaries , getPoolIds: Right <$> runQueryM' OgmiosHttp.getPoolIds , getPubKeyHashDelegationsAndRewards: \_ pubKeyHash -> diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 04241bbd01..a7ecaa4174 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -6,7 +6,6 @@ module Ctl.Internal.QueryM ( QueryM , ParQueryM , QueryMT(QueryMT) - , evaluateTxOgmios , handleAffjaxResponse ) where @@ -19,7 +18,6 @@ import Cardano.Provider.Error ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) , ServiceError(ServiceOtherError) ) -import Cardano.Types.CborBytes (CborBytes) import Control.Alt (class Alt) import Control.Alternative (class Alternative) import Control.Monad.Error.Class (class MonadError, class MonadThrow) @@ -30,20 +28,11 @@ import Control.Monad.Rec.Class (class MonadRec) import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) import Ctl.Internal.Helpers (logWithLevel) -import Ctl.Internal.Logging (mkLogger) -import Ctl.Internal.QueryM.Ogmios (AdditionalUtxoSet, OgmiosTxEvaluationR) -import Ctl.Internal.QueryM.Ogmios as Ogmios -import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool - ( listeners - , mkRequestAff - , underlyingWebSocket - ) import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right)) import Data.Maybe (fromMaybe) import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Tuple.Nested ((/\)) import Effect.Aff (Aff, ParAff) import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Class (class MonadEffect) @@ -101,25 +90,6 @@ instance Parallel (QueryMT ParAff) (QueryMT Aff) where sequential :: QueryMT ParAff ~> QueryMT Aff sequential = wrap <<< sequential <<< unwrap --------------------------------------------------------------------------------- --- Ogmios Local Tx Submission Protocol --------------------------------------------------------------------------------- - -evaluateTxOgmios - :: CborBytes -> AdditionalUtxoSet -> QueryM OgmiosTxEvaluationR -evaluateTxOgmios cbor additionalUtxos = do - ws <- asks $ underlyingWebSocket <<< _.ogmiosWs <<< _.runtime - listeners' <- asks $ listeners <<< _.ogmiosWs <<< _.runtime - cfg <- asks _.config - liftAff $ mkRequestAff listeners' ws (mkLogger cfg.logLevel cfg.customLogger) - Ogmios.evaluateTxCall - _.evaluate - (cbor /\ additionalUtxos) - --------------------------------------------------------------------------------- --- Ogmios Local Tx Monitor Protocol --------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- -- Affjax -------------------------------------------------------------------------------- diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 1db2fbc463..5a59c72492 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -25,8 +25,6 @@ module Ctl.Internal.QueryM.Ogmios , MaybeMempoolTransaction(MaybeMempoolTransaction) , OgmiosTxEvaluationR(OgmiosTxEvaluationR) , aesonObject - , aesonArray - , evaluateTxCall , submitSuccessPartialResp , parseIpv6String , rationalToSubcoin @@ -84,7 +82,6 @@ import Cardano.Types import Cardano.Types.AssetName (unAssetName) import Cardano.Types.BigNum (BigNum) import Cardano.Types.BigNum (fromBigInt, fromString) as BigNum -import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.Coin (Coin(Coin)) import Cardano.Types.CostModel (CostModel(CostModel)) import Cardano.Types.Ed25519KeyHash (Ed25519KeyHash) @@ -131,12 +128,9 @@ import Control.Alternative (guard) import Ctl.Internal.Helpers (encodeMap, showWithParens) import Ctl.Internal.QueryM.JsonRpc2 ( class DecodeOgmios - , JsonRpc2Call - , JsonRpc2Request , OgmiosError , decodeErrorOrResult , decodeResult - , mkCallType ) import Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) @@ -178,37 +172,8 @@ import JS.BigInt as BigInt import Untagged.TypeCheck (class HasRuntimeType) import Untagged.Union (type (|+|), toEither1) --------------------------------------------------------------------------------- --- Local Tx Submission Protocol --- https://ogmios.dev/mini-protocols/local-tx-submission/ -------------------------------------------------------------------------------- --- | Evaluates the execution units of scripts present in a given transaction, --- | without actually submitting the transaction. -evaluateTxCall - :: JsonRpc2Call (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR -evaluateTxCall = mkOgmiosCallType - { method: "evaluateTransaction" - , params: \(cbor /\ utxoqr) -> - { transaction: { cbor: byteArrayToHex $ unwrap cbor } - , additionalUtxo: utxoqr - } - } - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -mkOgmiosCallType - :: forall (a :: Type) (i :: Type) (o :: Type) - . EncodeAeson (JsonRpc2Request a) - => DecodeOgmios o - => { method :: String, params :: i -> a } - -> JsonRpc2Call i o -mkOgmiosCallType = - mkCallType { jsonrpc: "2.0" } - --------------------------------------------------------------------------------- -- Local Tx Monitor Query Response & Parsing -------------------------------------------------------------------------------- diff --git a/src/Internal/QueryM/OgmiosHttp.purs b/src/Internal/QueryM/OgmiosHttp.purs index ad0da2c946..631d434cd4 100644 --- a/src/Internal/QueryM/OgmiosHttp.purs +++ b/src/Internal/QueryM/OgmiosHttp.purs @@ -9,7 +9,7 @@ module Ctl.Internal.QueryM.OgmiosHttp , delegationsAndRewards , eraSummaries , getProtocolParameters - -- , evaluateTxOgmios + , evaluateTxOgmios ) where import Prelude @@ -104,11 +104,13 @@ import Ctl.Internal.QueryM.JsonRpc2 , pprintOgmiosDecodeError ) import Ctl.Internal.QueryM.Ogmios - ( CurrentEpoch + ( AdditionalUtxoSet + , CurrentEpoch , DelegationsAndRewardsR(DelegationsAndRewardsR) , OgmiosEraSummaries , OgmiosProtocolParameters , OgmiosSystemStart + , OgmiosTxEvaluationR , PoolParametersR , SubmitTxR ) as Ogmios @@ -272,28 +274,28 @@ delegationsAndRewards rewardAccounts = do } ) --- evaluateTxOgmios --- :: CborBytes -> AdditionalUtxoSet -> QueryM Provider.TxEvaluationR --- evaluateTxOgmios cbor additionalUtxos = ogmiosErrorHandlerWithArg --- evaluateTx --- (cbor /\ additionalUtxos) --- where --- evaluateTx --- :: CborBytes /\ AdditionalUtxoSet --- -> Aff (Either OgmiosDecodeError Provider.TxEvaluationR) --- evaluateTx (cbor /\ utxoqr) = do --- handleAffjaxOgmiosResponse <$> --- ( ogmiosPostRequest --- $ Aeson.encodeAeson --- { jsonrpc: "2.0" --- , id: "evaluateTxOgmios" --- , method: "evaluateTransaction" --- , params: --- { transaction: { cbor: byteArrayToHex $ unwrap cbor } --- , additionalUtxo: utxoqr --- } --- } --- ) +evaluateTxOgmios + :: CborBytes -> Ogmios.AdditionalUtxoSet -> QueryM Provider.TxEvaluationR +evaluateTxOgmios cbor additionalUtxos = unwrap <$> ogmiosErrorHandlerWithArg + evaluateTx + (cbor /\ additionalUtxos) + where + evaluateTx + :: CborBytes /\ Ogmios.AdditionalUtxoSet + -> QueryM (Either OgmiosDecodeError Ogmios.OgmiosTxEvaluationR) + evaluateTx (cbor_ /\ utxoqr) = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "evaluateTxOgmios" + , method: "evaluateTransaction" + , params: + { transaction: { cbor: byteArrayToHex $ unwrap cbor_ } + , additionalUtxo: utxoqr + } + } + ) instance DecodeOgmios TxEvaluationR where decodeOgmios = decodeErrorOrResult From 141a59be254a4e32e62837c69f5f44f1569cc286 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 12:58:34 -0300 Subject: [PATCH 05/27] Extract Ogmios types into separate module --- src/Contract/Backend/Ogmios.purs | 4 +- src/Contract/Backend/Ogmios/Mempool.purs | 14 +- src/Contract/Time.purs | 2 +- src/Internal/BalanceTx/ExUnitsAndMinFee.purs | 2 +- src/Internal/Contract/Monad.purs | 8 +- src/Internal/Contract/Provider.purs | 4 +- src/Internal/Contract/ProviderBackend.purs | 2 +- src/Internal/QueryM.purs | 2 +- src/Internal/QueryM/CurrentEpoch.purs | 4 +- src/Internal/QueryM/EraSummaries.purs | 2 +- src/Internal/QueryM/Ogmios.purs | 735 ++++++++--------- .../Dispatcher.purs | 2 +- .../JsWebSocket.js | 0 .../JsWebSocket.purs | 2 +- .../{OgmiosWebsocket => Ogmios}/Mempool.purs | 54 +- .../{OgmiosWebsocket => Ogmios}/Queries.purs | 6 +- .../{OgmiosHttp.purs => Ogmios/Types.purs} | 737 +++++++++--------- src/Internal/QueryM/Pools.purs | 4 +- src/Internal/ServerConfig.purs | 2 +- src/Internal/Service/Blockfrost.purs | 2 +- src/Internal/Test/E2E/Feedback/Browser.purs | 2 +- src/Internal/Test/E2E/Feedback/Node.purs | 2 +- src/Internal/Test/E2E/Route.purs | 2 +- src/Internal/Test/E2E/Runner.purs | 2 +- test/Ogmios/Aeson.purs | 4 +- test/Ogmios/EvaluateTx.purs | 2 +- test/Ogmios/GenerateFixtures.purs | 6 +- test/Plutus/Time.purs | 2 +- test/ProtocolParameters.purs | 2 +- test/QueryM/AffInterface.purs | 2 +- test/Testnet/Contract/OgmiosMempool.purs | 10 +- test/Types/Interval.purs | 2 +- test/Types/Ipv6.purs | 2 +- 33 files changed, 814 insertions(+), 814 deletions(-) rename src/Internal/QueryM/{OgmiosWebsocket => Ogmios}/Dispatcher.purs (98%) rename src/Internal/QueryM/{OgmiosWebsocket => Ogmios}/JsWebSocket.js (100%) rename src/Internal/QueryM/{OgmiosWebsocket => Ogmios}/JsWebSocket.purs (96%) rename src/Internal/QueryM/{OgmiosWebsocket => Ogmios}/Mempool.purs (98%) rename src/Internal/QueryM/{OgmiosWebsocket => Ogmios}/Queries.purs (92%) rename src/Internal/QueryM/{OgmiosHttp.purs => Ogmios/Types.purs} (66%) diff --git a/src/Contract/Backend/Ogmios.purs b/src/Contract/Backend/Ogmios.purs index d9effe0f5e..78a7747a5c 100644 --- a/src/Contract/Backend/Ogmios.purs +++ b/src/Contract/Backend/Ogmios.purs @@ -11,8 +11,8 @@ import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.TransactionHash (TransactionHash) import Contract.Monad (Contract) import Ctl.Internal.Contract.Monad (wrapQueryM) -import Ctl.Internal.QueryM.Ogmios (SubmitTxR) -import Ctl.Internal.QueryM.OgmiosHttp (submitTxOgmios) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios (submitTxOgmios) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios.Types (SubmitTxR) import Ctl.Internal.QueryM.Pools (getPoolParameters) as QueryM -- | **This function can only run with Ogmios backend** diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index 46fc959f57..a6a41b0358 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -23,13 +23,8 @@ import Ctl.Internal.Contract.Monad (wrapQueryM) import Ctl.Internal.Logging (Logger, mkLogger) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 -import Ctl.Internal.QueryM.Ogmios - ( MempoolSizeAndCapacity - , MempoolSnapshotAcquired - , MempoolTransaction(MempoolTransaction) - ) as Ogmios -import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (JsWebSocket) -import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool +import Ctl.Internal.QueryM.Ogmios.JsWebSocket (JsWebSocket) +import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , OgmiosListeners , acquireMempoolSnapshotCall @@ -41,6 +36,11 @@ import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool , releaseMempoolCall , underlyingWebSocket ) +import Ctl.Internal.QueryM.Ogmios.Types + ( MempoolSizeAndCapacity + , MempoolSnapshotAcquired + , MempoolTransaction(MempoolTransaction) + ) as Ogmios import Data.Array as Array import Data.ByteArray (hexToByteArray) import Data.List (List(Cons)) diff --git a/src/Contract/Time.purs b/src/Contract/Time.purs index 0a052c1236..83aca1a4c5 100644 --- a/src/Contract/Time.purs +++ b/src/Contract/Time.purs @@ -40,7 +40,7 @@ import Control.Monad.Reader.Class (asks) import Ctl.Internal.Contract (getChainTip) import Ctl.Internal.Contract.Monad (getProvider) import Ctl.Internal.Helpers (liftM) -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Types ( CurrentEpoch(CurrentEpoch) , OgmiosEraSummaries(OgmiosEraSummaries) ) as ExportOgmios diff --git a/src/Internal/BalanceTx/ExUnitsAndMinFee.purs b/src/Internal/BalanceTx/ExUnitsAndMinFee.purs index 27512265f2..63fbe069cf 100644 --- a/src/Internal/BalanceTx/ExUnitsAndMinFee.purs +++ b/src/Internal/BalanceTx/ExUnitsAndMinFee.purs @@ -52,7 +52,7 @@ import Ctl.Internal.BalanceTx.Types import Ctl.Internal.Contract.MinFee (calculateMinFee) as Contract.MinFee import Ctl.Internal.Contract.Monad (getProvider) import Ctl.Internal.Helpers (liftEither, unsafeFromJust) -import Ctl.Internal.QueryM.Ogmios (AdditionalUtxoSet) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types (AdditionalUtxoSet) as Ogmios import Ctl.Internal.Transaction (setScriptDataHash) import Ctl.Internal.TxOutput ( transactionInputToTxOutRef diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index 146cd22475..335c6619ae 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -58,17 +58,17 @@ import Ctl.Internal.Logging (Logger, mkLogger, setupLogs) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (OgmiosDecodeError, pprintOgmiosDecodeError) import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) -import Ctl.Internal.QueryM.OgmiosHttp +import Ctl.Internal.QueryM.Ogmios ( getProtocolParameters , getSystemStartTime ) -import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (_wsClose, _wsFinalize) -import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool +import Ctl.Internal.QueryM.Ogmios.JsWebSocket (_wsClose, _wsFinalize) +import Ctl.Internal.QueryM.Ogmios.Mempool ( WebSocket , mkOgmiosWebSocketAff , underlyingWebSocket ) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) +import Ctl.Internal.QueryM.Ogmios.Queries (QueryEnv) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM diff --git a/src/Internal/Contract/Provider.purs b/src/Internal/Contract/Provider.purs index 20dfd3525a..9b511b0184 100644 --- a/src/Internal/Contract/Provider.purs +++ b/src/Internal/Contract/Provider.purs @@ -27,12 +27,12 @@ import Ctl.Internal.QueryM.Kupo , isTxConfirmed , utxosAt ) as Kupo -import Ctl.Internal.QueryM.Ogmios (SubmitTxR(SubmitFail, SubmitTxSuccess)) -import Ctl.Internal.QueryM.OgmiosHttp +import Ctl.Internal.QueryM.Ogmios ( evaluateTxOgmios , getChainTip , submitTxOgmios ) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios.Types (SubmitTxR(SubmitFail, SubmitTxSuccess)) import Ctl.Internal.QueryM.Pools ( getPoolIds , getPubKeyHashDelegationsAndRewards diff --git a/src/Internal/Contract/ProviderBackend.purs b/src/Internal/Contract/ProviderBackend.purs index 4bcfa8b86d..5cba5c568b 100644 --- a/src/Internal/Contract/ProviderBackend.purs +++ b/src/Internal/Contract/ProviderBackend.purs @@ -15,7 +15,7 @@ module Ctl.Internal.Contract.ProviderBackend import Prelude -import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool (OgmiosWebSocket) +import Ctl.Internal.QueryM.Ogmios.Mempool (OgmiosWebSocket) import Ctl.Internal.ServerConfig (ServerConfig) import Data.Maybe (Maybe(Just, Nothing)) import Data.Time.Duration (Seconds(Seconds)) diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index a7ecaa4174..105544cdba 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -28,7 +28,7 @@ import Control.Monad.Rec.Class (class MonadRec) import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) import Ctl.Internal.Helpers (logWithLevel) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (QueryEnv) +import Ctl.Internal.QueryM.Ogmios.Queries (QueryEnv) import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right)) import Data.Maybe (fromMaybe) diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index d2c8958dcc..a9695679f5 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -8,8 +8,8 @@ import Prelude import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) -import Ctl.Internal.QueryM.Ogmios (CurrentEpoch) -import Ctl.Internal.QueryM.OgmiosHttp (currentEpoch) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios (currentEpoch) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios.Types (CurrentEpoch) import Data.Either (Either(Right, Left)) import Effect.Exception (error) diff --git a/src/Internal/QueryM/EraSummaries.purs b/src/Internal/QueryM/EraSummaries.purs index f8ec010c5a..a07c05d622 100644 --- a/src/Internal/QueryM/EraSummaries.purs +++ b/src/Internal/QueryM/EraSummaries.purs @@ -9,7 +9,7 @@ import Cardano.Types.EraSummaries (EraSummaries) import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) -import Ctl.Internal.QueryM.OgmiosHttp (eraSummaries) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios (eraSummaries) as OgmiosHttp import Data.Either (Either(Right, Left)) import Data.Newtype (unwrap) import Effect.Exception (error) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 5a59c72492..99cce01ca3 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -1,33 +1,15 @@ --- | Provides types and instances to create Ogmios requests and decode --- | its responses. module Ctl.Internal.QueryM.Ogmios - ( ChainOrigin(ChainOrigin) - , ChainPoint - , ChainTipQR(CtChainOrigin, CtChainPoint) - , CurrentEpoch(CurrentEpoch) - , DelegationsAndRewardsR(DelegationsAndRewardsR) - , MempoolSizeAndCapacity(MempoolSizeAndCapacity) - , MempoolSnapshotAcquired - , MempoolTransaction(MempoolTransaction) - , OgmiosBlockHeaderHash(OgmiosBlockHeaderHash) - , OgmiosProtocolParameters(OgmiosProtocolParameters) - , PParamRational(PParamRational) - , PoolParameters - , PoolParametersR(PoolParametersR) - , ReleasedMempool(ReleasedMempool) - , AdditionalUtxoSet(AdditionalUtxoSet) - , OgmiosUtxoMap - , OgmiosEraSummaries(OgmiosEraSummaries) - , OgmiosSystemStart(OgmiosSystemStart) - , SubmitTxR(SubmitTxSuccess, SubmitFail) - , StakePoolsQueryArgument(StakePoolsQueryArgument) - , HasTxR(HasTxR) - , MaybeMempoolTransaction(MaybeMempoolTransaction) - , OgmiosTxEvaluationR(OgmiosTxEvaluationR) + ( getSystemStartTime , aesonObject - , submitSuccessPartialResp - , parseIpv6String - , rationalToSubcoin + , getChainTip + , currentEpoch + , submitTxOgmios + , poolParameters + , StakePoolsQueryArgument(StakePoolsQueryArgument) + , delegationsAndRewards + , eraSummaries + , getProtocolParameters + , evaluateTxOgmios ) where import Prelude @@ -36,55 +18,46 @@ import Aeson ( class DecodeAeson , class EncodeAeson , Aeson - , JsonDecodeError(AtKey, TypeMismatch, UnexpectedValue, MissingValue) + , JsonDecodeError(TypeMismatch, MissingValue, AtKey) , caseAesonArray - , caseAesonNull , caseAesonObject , caseAesonString , decodeAeson , encodeAeson , fromArray - , fromString , getField , isNull + , parseJsonStringToAeson , stringifyAeson - , (.:) , (.:?) ) -import Cardano.AsCbor (decodeCbor, encodeCbor) -import Cardano.Provider.TxEvaluation - ( ExecutionUnits - , OgmiosTxId - , OgmiosTxOut - , OgmiosTxOutRef - , RedeemerPointer - , ScriptFailure - ( InternalLedgerTypeConversionError - , NoCostModelForLanguage - , UnknownInputReferencedByRedeemer - , MissingRequiredDatums - , ExtraRedeemers - , NonScriptInputReferencedByRedeemer - , ValidatorFailed - , MissingRequiredScripts - ) - , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) - , TxEvaluationR(TxEvaluationR) - , TxEvaluationResult(TxEvaluationResult) +import Aeson as Aeson +import Affjax (Error, Response, defaultRequest) as Affjax +import Affjax.RequestBody as Affjax.RequestBody +import Affjax.RequestHeader as Affjax.RequestHeader +import Affjax.ResponseFormat (string) as Affjax.ResponseFormat +import Affjax.StatusCode (StatusCode(StatusCode)) +import Affjax.StatusCode as Affjax.StatusCode +import Cardano.AsCbor (encodeCbor) +import Cardano.Provider.Error + ( ClientError(ClientHttpError, ClientHttpResponseError) + , ServiceError(ServiceOtherError) ) -import Cardano.Serialization.Lib (fromBytes, ipv4_new) +import Cardano.Provider.TxEvaluation as Provider +import Cardano.Serialization.Lib (fromBytes) import Cardano.Types - ( BigNum(BigNum) + ( Bech32String + , BigNum(BigNum) , Language(PlutusV3, PlutusV2, PlutusV1) , RedeemerTag - , VRFKeyHash(VRFKeyHash) ) import Cardano.Types.AssetName (unAssetName) import Cardano.Types.BigNum (BigNum) -import Cardano.Types.BigNum (fromBigInt, fromString) as BigNum +import Cardano.Types.BigNum (fromBigInt) as BigNum +import Cardano.Types.CborBytes (CborBytes) +import Cardano.Types.Chain as Chain import Cardano.Types.Coin (Coin(Coin)) import Cardano.Types.CostModel (CostModel(CostModel)) -import Cardano.Types.Ed25519KeyHash (Ed25519KeyHash) import Cardano.Types.EraSummaries ( EraSummaries(EraSummaries) , EraSummary(EraSummary) @@ -94,8 +67,6 @@ import Cardano.Types.EraSummaries import Cardano.Types.ExUnitPrices (ExUnitPrices(ExUnitPrices)) import Cardano.Types.ExUnits (ExUnits(ExUnits)) import Cardano.Types.Int as Cardano -import Cardano.Types.Ipv4 (Ipv4(Ipv4)) -import Cardano.Types.Ipv6 (Ipv6) import Cardano.Types.NativeScript ( NativeScript ( ScriptPubkey @@ -107,31 +78,43 @@ import Cardano.Types.NativeScript ) ) import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) -import Cardano.Types.PoolMetadata (PoolMetadata(PoolMetadata)) import Cardano.Types.PoolPubKeyHash (PoolPubKeyHash) import Cardano.Types.RedeemerTag ( RedeemerTag(Spend, Mint, Cert, Reward, Vote, Propose) ) as RedeemerTag -import Cardano.Types.Relay - ( Relay(SingleHostAddr, SingleHostName, MultiHostName) - ) -import Cardano.Types.RewardAddress (RewardAddress) -import Cardano.Types.RewardAddress as RewardAddress +import Cardano.Types.ScriptHash (ScriptHash) import Cardano.Types.ScriptRef (ScriptRef(NativeScriptRef, PlutusScriptRef)) import Cardano.Types.Slot (Slot(Slot)) import Cardano.Types.TransactionHash (TransactionHash) -import Cardano.Types.URL (URL(URL)) import Cardano.Types.UnitInterval (UnitInterval(UnitInterval)) import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) -import Control.Alt ((<|>)) -import Control.Alternative (guard) +import Contract.Log (logTrace') +import Control.Monad.Error.Class (class MonadThrow, throwError) +import Control.Monad.Reader.Class (asks) +import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Helpers (encodeMap, showWithParens) +import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 ( class DecodeOgmios + , OgmiosDecodeError(ClientErrorResponse, ResultDecodingError) , OgmiosError , decodeErrorOrResult + , decodeOgmios , decodeResult + , pprintOgmiosDecodeError ) +import Ctl.Internal.QueryM.Ogmios.Types + ( AdditionalUtxoSet + , CurrentEpoch + , DelegationsAndRewardsR(DelegationsAndRewardsR) + , OgmiosEraSummaries + , OgmiosProtocolParameters + , OgmiosSystemStart + , OgmiosTxEvaluationR + , PoolParametersR + , SubmitTxR + ) as Ogmios +import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) import Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) ) @@ -142,15 +125,15 @@ import Ctl.Internal.Types.SystemStart , sysStartFromOgmiosTimestamp , sysStartToOgmiosTimestamp ) -import Data.Argonaut.Encode.Encoders as Argonaut import Data.Array (catMaybes) -import Data.Array (fromFoldable, length, replicate) as Array +import Data.Array (fromFoldable) as Array import Data.Bifunctor (lmap) -import Data.ByteArray (byteArrayFromIntArray, byteArrayToHex, hexToByteArray) +import Data.ByteArray (byteArrayToHex, hexToByteArray) import Data.Either (Either(Left, Right), either, note) -import Data.Foldable (fold, foldl) +import Data.Foldable (foldl) import Data.Generic.Rep (class Generic) -import Data.Int (fromString) as Int +import Data.HTTP.Method (Method(POST)) +import Data.Lens (_Right, to, (^?)) import Data.List (List) import Data.List as List import Data.Map (Map) @@ -158,22 +141,173 @@ import Data.Map as Map import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe) import Data.Newtype (class Newtype, unwrap, wrap) import Data.Show.Generic (genericShow) -import Data.String (Pattern(Pattern), Replacement(Replacement)) -import Data.String (replaceAll) as String +import Data.String (Pattern(Pattern)) import Data.String.Common (split) as String -import Data.String.Utils as StringUtils +import Data.Time.Duration (Milliseconds(Milliseconds)) import Data.Traversable (for, traverse) import Data.Tuple (Tuple(Tuple)) import Data.Tuple.Nested (type (/\), (/\)) import Data.UInt (UInt) +import Effect.Aff (Aff, delay) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Exception (Error, error) import Foreign.Object (Object) import Foreign.Object as Object import JS.BigInt as BigInt import Untagged.TypeCheck (class HasRuntimeType) import Untagged.Union (type (|+|), toEither1) +eraSummaries :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosEraSummaries) +eraSummaries = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "eraSummaries" + , method: "queryLedgerState/eraSummaries" + } + ) + +getSystemStartTime :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosSystemStart) +getSystemStartTime = do + let + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "getSystemStartTime" + , method: "queryNetwork/startTime" + } + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body + +getProtocolParameters + :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosProtocolParameters) +getProtocolParameters = do + let + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "getProtocolParameters" + , method: "queryLedgerState/protocolParameters" + } + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body + +getChainTip :: QueryM Chain.Tip +getChainTip = do + ogmiosChainTipToTip <$> ogmiosErrorHandler chainTip + where + ogmiosChainTipToTip :: ChainTipQR -> Chain.Tip + ogmiosChainTipToTip = case _ of + CtChainOrigin _ -> Chain.TipAtGenesis + CtChainPoint { slot, id } -> Chain.Tip $ wrap + { slot, blockHeaderHash: wrap $ unwrap id } + + chainTip :: QueryM (Either OgmiosDecodeError ChainTipQR) + chainTip = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "getChainTip" + , method: "queryNetwork/tip" + } + ) + +currentEpoch :: QueryM (Either OgmiosDecodeError Ogmios.CurrentEpoch) +currentEpoch = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "currentEpoch" + , method: "queryLedgerState/epoch" + } + ) + +submitTxOgmios :: TransactionHash -> CborBytes -> QueryM Ogmios.SubmitTxR +submitTxOgmios txHash tx = ogmiosErrorHandlerWithArg submitTx + (txHash /\ tx) + where + submitTx + :: TransactionHash /\ CborBytes + -> QueryM (Either OgmiosDecodeError Ogmios.SubmitTxR) + submitTx (_ /\ cbor) = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "submitTxOgmios" + , method: "submitTransaction" + , params: + { transaction: + { cbor: byteArrayToHex (unwrap cbor) + } + } + } + ) + +poolParameters + :: StakePoolsQueryArgument + -> QueryM (Either OgmiosDecodeError Ogmios.PoolParametersR) +poolParameters stakePools = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "poolParameters" + , method: "queryLedgerState/stakePools" + , params: stakePools + } + ) + +delegationsAndRewards + :: Array String -- ^ A list of reward account bech32 strings + -> QueryM (Either OgmiosDecodeError Ogmios.DelegationsAndRewardsR) +delegationsAndRewards rewardAccounts = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "delegationsAndRewards" + , method: "queryLedgerState/rewardAccountSummaries" + , params: + { query: + { delegationsAndRewards: rewardAccounts } + } + } + ) + +evaluateTxOgmios + :: CborBytes -> Ogmios.AdditionalUtxoSet -> QueryM Provider.TxEvaluationR +evaluateTxOgmios cbor additionalUtxos = unwrap <$> ogmiosErrorHandlerWithArg + evaluateTx + (cbor /\ additionalUtxos) + where + evaluateTx + :: CborBytes /\ Ogmios.AdditionalUtxoSet + -> QueryM (Either OgmiosDecodeError Ogmios.OgmiosTxEvaluationR) + evaluateTx (cbor_ /\ utxoqr) = do + handleAffjaxOgmiosResponse <$> + ( ogmiosPostRequest + $ Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "evaluateTxOgmios" + , method: "evaluateTransaction" + , params: + { transaction: { cbor: byteArrayToHex $ unwrap cbor_ } + , additionalUtxo: utxoqr + } + } + ) + +instance DecodeOgmios TxEvaluationR where + decodeOgmios = decodeErrorOrResult + { parseError: map (wrap <<< Left) <<< decodeAeson } + { parseResult: map (wrap <<< Right) <<< decodeAeson } + +-- Response parsing -------------------------------------------------------------------------------- +type OgmiosAddress = Bech32String + +-------------------------------------------------------------------------------- -- Local Tx Monitor Query Response & Parsing -------------------------------------------------------------------------------- @@ -184,100 +318,8 @@ derive instance Newtype HasTxR _ instance DecodeOgmios HasTxR where decodeOgmios = decodeResult (map HasTxR <<< decodeAeson) -newtype MempoolSnapshotAcquired = AwaitAcquired Slot - -instance Show MempoolSnapshotAcquired where - show (AwaitAcquired slot) = "(AwaitAcquired " <> show slot <> ")" - -instance DecodeAeson MempoolSnapshotAcquired where - decodeAeson = - -- todo: ignoring "acquired": "mempool" - map AwaitAcquired <<< aesonObject (flip getField "slot") - -instance DecodeOgmios MempoolSnapshotAcquired where - decodeOgmios = decodeResult decodeAeson - --- | The acquired snapshot’s size (in bytes), number of transactions, and capacity --- | (in bytes). -newtype MempoolSizeAndCapacity = MempoolSizeAndCapacity - { capacity :: Prim.Int - , currentSize :: Prim.Int - , numberOfTxs :: Prim.Int - } - -derive instance Generic MempoolSizeAndCapacity _ -derive instance Newtype MempoolSizeAndCapacity _ - -instance Show MempoolSizeAndCapacity where - show = genericShow - -instance DecodeAeson MempoolSizeAndCapacity where - decodeAeson = aesonObject \o -> do - capacity <- getField o "maxCapacity" >>= flip getField "bytes" - currentSize <- getField o "currentSize" >>= flip getField "bytes" - numberOfTxs <- getField o "transactions" >>= flip getField "count" - pure $ wrap { capacity, currentSize, numberOfTxs } - -instance DecodeOgmios MempoolSizeAndCapacity where - decodeOgmios = decodeResult decodeAeson - -newtype MempoolTransaction = MempoolTransaction - { id :: OgmiosTxId - , raw :: String -- hex encoded transaction cbor - } - -derive instance Generic MempoolTransaction _ -derive instance Newtype MempoolTransaction _ - -newtype MaybeMempoolTransaction = MaybeMempoolTransaction - (Maybe MempoolTransaction) - -instance DecodeAeson MaybeMempoolTransaction where - decodeAeson aeson = do - { transaction: tx } :: { transaction :: Aeson } <- decodeAeson aeson - res <- - ( do - tx' :: { id :: String, cbor :: String } <- decodeAeson tx - pure $ Just $ MempoolTransaction { id: tx'.id, raw: tx'.cbor } - ) <|> - ( do - aesonNull tx - pure Nothing - ) - pure $ MaybeMempoolTransaction $ res - -derive instance Newtype MaybeMempoolTransaction _ - -instance DecodeOgmios MaybeMempoolTransaction where - decodeOgmios = decodeResult decodeAeson - -data ReleasedMempool = ReleasedMempool - -derive instance Generic ReleasedMempool _ - -instance Show ReleasedMempool where - show = genericShow - -instance DecodeAeson ReleasedMempool where - decodeAeson = aesonObject \o -> do - released <- o .: "released" - flip aesonString released $ \s -> - if s == "mempool" then - pure $ ReleasedMempool - else - Left (UnexpectedValue $ Argonaut.encodeString s) - -instance DecodeOgmios ReleasedMempool where - decodeOgmios = decodeResult decodeAeson - ---------------- TX SUBMISSION QUERY RESPONSE & PARSING -submitSuccessPartialResp - :: TransactionHash - -> { result :: { transaction :: { id :: TransactionHash } } } -submitSuccessPartialResp txHash = - { "result": { "transaction": { "id": txHash } } } - data SubmitTxR = SubmitTxSuccess TransactionHash | SubmitFail OgmiosError @@ -393,8 +435,8 @@ instance DecodeAeson OgmiosEraSummaries where pure $ wrap { epochLength, slotLength, safeZone } instance EncodeAeson OgmiosEraSummaries where - encodeAeson (OgmiosEraSummaries (EraSummaries eraSummaries)) = - fromArray $ map encodeEraSummary eraSummaries + encodeAeson (OgmiosEraSummaries (EraSummaries es)) = + fromArray $ map encodeEraSummary es where encodeEraSummaryTime :: EraSummaryTime -> Aeson encodeEraSummaryTime (EraSummaryTime { time, slot, epoch }) = @@ -460,189 +502,35 @@ instance EncodeAeson StakePoolsQueryArgument where ) (unwrap a) ----------------- POOL PARAMETERS QUERY RESPONSE & PARSING - -type PoolParameters = - { vrfKeyhash :: VRFKeyHash - -- needed to prove that the pool won the lottery - , pledge :: BigNum - , cost :: BigNum -- >= pparams.minPoolCost - , margin :: UnitInterval -- proportion that goes to the reward account - , rewardAccount :: RewardAddress - , poolOwners :: Array Ed25519KeyHash - -- payment key hashes that contribute to pledge amount - , relays :: Array Relay - , poolMetadata :: Maybe PoolMetadata - } - -newtype PoolParametersR = PoolParametersR (Map PoolPubKeyHash PoolParameters) - -derive instance Newtype PoolParametersR _ -derive instance Generic PoolParametersR _ - -instance Show PoolParametersR where - show = genericShow - -instance DecodeAeson PoolParametersR where - decodeAeson aeson = do - obj :: Object (Object Aeson) <- decodeAeson aeson - kvs <- for (Object.toUnfoldable obj :: Array _) \(Tuple k objParams) -> do - poolPkh <- decodeAeson $ fromString k - poolParams <- decodePoolParameters objParams - pure $ poolPkh /\ poolParams - pure $ PoolParametersR $ Map.fromFoldable kvs - -instance DecodeOgmios PoolParametersR where - decodeOgmios = decodeResult decodeAeson +---------------- TX EVALUATION QUERY RESPONSE & PARSING -decodePoolParameters :: Object Aeson -> Either JsonDecodeError PoolParameters -decodePoolParameters objParams = do - vrfKeyhash <- decodeVRFKeyHash =<< objParams .: "vrfVerificationKeyHash" - pledge <- objParams .: "pledge" >>= aesonObject \obj -> - obj .: "ada" >>= flip getField "lovelace" - cost <- objParams .: "cost" >>= aesonObject \obj -> - obj .: "ada" >>= flip getField "lovelace" - margin <- decodeUnitInterval =<< objParams .: "margin" - rewardAccount <- objParams .: "rewardAccount" >>= - RewardAddress.fromBech32 >>> note (TypeMismatch "RewardAddress") - poolOwners <- objParams .: "owners" - relayArr <- objParams .: "relays" - relays <- for relayArr decodeRelay - poolMetadata <- objParams .:? "metadata" >>= traverse decodePoolMetadata - pure - { vrfKeyhash - , pledge - , cost - , margin - , rewardAccount - , poolOwners - , relays - , poolMetadata - } - -decodeVRFKeyHash :: Aeson -> Either JsonDecodeError VRFKeyHash -decodeVRFKeyHash = aesonString $ \vrfKeyhashHex -> do - vrfKeyhashBytes <- note (TypeMismatch "VRFKeyHash") $ hexToByteArray - vrfKeyhashHex - note (TypeMismatch "VRFKeyHash") $ VRFKeyHash <$> fromBytes vrfKeyhashBytes - -decodeUnitInterval :: Aeson -> Either JsonDecodeError UnitInterval -decodeUnitInterval aeson = do - str <- decodeAeson aeson - case String.split (Pattern "/") str of - [ num, den ] -> do - numerator <- note (TypeMismatch "BigNum") $ BigNum.fromString num - denominator <- note (TypeMismatch "BigNum") $ BigNum.fromString den - pure $ UnitInterval - { numerator - , denominator - } - _ -> Left $ TypeMismatch "UnitInterval" - -decodeIpv4 :: Aeson -> Either JsonDecodeError Ipv4 -decodeIpv4 aeson = do - str <- decodeAeson aeson - case String.split (Pattern ".") str of - bs@[ _, _, _, _ ] -> do - ints <- for bs $ - note (TypeMismatch "Ipv4") <<< Int.fromString - Ipv4 <<< ipv4_new <$> note (TypeMismatch "Ipv4") - (byteArrayFromIntArray ints) - _ -> Left $ TypeMismatch "Ipv4" - -decodeIpv6 :: Aeson -> Either JsonDecodeError Ipv6 -decodeIpv6 aeson = do - decodeAeson aeson >>= parseIpv6String >>> note (TypeMismatch "Ipv6") - -parseIpv6String :: String -> Maybe Ipv6 -parseIpv6String str = do - let - parts = String.split (Pattern ":") str - partsFixed = - if Array.length parts < 8 then - -- Normalize double colon - -- see https://ipcisco.com/lesson/ipv6-address/ - do - part <- parts - if part == "" then - Array.replicate (8 - Array.length parts + 1) "" - else - pure part - else - parts - guard (Array.length partsFixed == 8) - let - padded = String.replaceAll (Pattern " ") (Replacement "0") $ fold $ - partsFixed - <#> StringUtils.padStart 4 - decodeCbor <<< wrap =<< hexToByteArray padded - -decodeRelay :: Aeson -> Either JsonDecodeError Relay -decodeRelay aeson = do - obj <- decodeAeson aeson - let - decodeSingleHostAddr = do - port <- obj .:? "port" - ipv4 <- obj .:? "ipv4" >>= traverse decodeIpv4 - ipv6 <- obj .:? "ipv6" >>= traverse decodeIpv6 - pure $ SingleHostAddr { port, ipv4, ipv6 } - decodeSingleHostName = do - port <- obj .: "port" - dnsName <- obj .: "hostname" - pure $ SingleHostName { port, dnsName } - decodeMultiHostName = do - dnsName <- obj .: "hostname" - pure $ MultiHostName { dnsName } - decodeSingleHostName <|> decodeSingleHostAddr <|> decodeMultiHostName - -decodePoolMetadata :: Aeson -> Either JsonDecodeError PoolMetadata -decodePoolMetadata aeson = do - obj <- decodeAeson aeson - hash <- obj .: "hash" >>= - (hexToByteArray >>> map wrap >=> decodeCbor) >>> - note (TypeMismatch "PoolMetadataHash") - url <- obj .: "url" <#> URL - pure $ PoolMetadata { hash, url } +type RedeemerPointer = { redeemerTag :: RedeemerTag, redeemerIndex :: UInt } ----------------- TX EVALUATION QUERY RESPONSE & PARSING +type ExecutionUnits = { memory :: BigNum, steps :: BigNum } type OgmiosRedeemerPtr = { index :: UInt, purpose :: String } -newtype OgmiosTxEvaluationR = OgmiosTxEvaluationR TxEvaluationR +newtype TxEvaluationR = TxEvaluationR + (Either TxEvaluationFailure TxEvaluationResult) -derive instance Newtype OgmiosTxEvaluationR _ -derive instance Generic OgmiosTxEvaluationR _ +derive instance Newtype TxEvaluationR _ +derive instance Generic TxEvaluationR _ -instance Show OgmiosTxEvaluationR where +instance Show TxEvaluationR where show = genericShow -instance DecodeOgmios OgmiosTxEvaluationR where - decodeOgmios = - decodeErrorOrResult - { parseError: - map - ( \(f :: OgmiosTxEvaluationFailure) -> - f # unwrap # Left # wrap # wrap - ) <<< decodeAeson - } - { parseResult: - map - ( \(r :: OgmiosTxEvaluationResult) -> r # unwrap # Right # wrap # - wrap - ) <<< decodeAeson - } - -newtype OgmiosTxEvaluationResult = OgmiosTxEvaluationResult TxEvaluationResult +newtype TxEvaluationResult = TxEvaluationResult + (Map RedeemerPointer ExecutionUnits) -derive instance Newtype OgmiosTxEvaluationResult _ -derive instance Generic OgmiosTxEvaluationResult _ +derive instance Newtype TxEvaluationResult _ +derive instance Generic TxEvaluationResult _ -instance Show OgmiosTxEvaluationResult where +instance Show TxEvaluationResult where show = genericShow -instance DecodeAeson OgmiosTxEvaluationResult where +instance DecodeAeson TxEvaluationResult where decodeAeson = aesonArray $ \array -> do - OgmiosTxEvaluationResult <<< TxEvaluationResult <<< Map.fromFoldable <$> + TxEvaluationResult <<< Map.fromFoldable <$> traverse decodeRdmrPtrExUnitsItem array where @@ -678,25 +566,53 @@ redeemerTagFromString = case _ of "propose" -> Just RedeemerTag.Propose _ -> Nothing -newtype OgmiosScriptFailure = OgmiosScriptFailure ScriptFailure +type OgmiosDatum = String +type OgmiosScript = String +type OgmiosTxId = String +type OgmiosTxIn = { txId :: OgmiosTxId, index :: Prim.Int } + +-- | Reason a script failed. +-- +-- The type definition is a least common denominator between Ogmios v6 format used by ogmios backend +-- and ogmios v5.6 format used by blockfrost backend +data ScriptFailure + = ExtraRedeemers (Array RedeemerPointer) + | MissingRequiredDatums + { missing :: (Array OgmiosDatum) + , provided :: Maybe (Array OgmiosDatum) + } + | MissingRequiredScripts + { missing :: Array RedeemerPointer + , resolved :: Maybe (Map RedeemerPointer ScriptHash) + } + | ValidatorFailed { error :: String, traces :: Array String } + | UnknownInputReferencedByRedeemer (Array OgmiosTxIn) + | NonScriptInputReferencedByRedeemer OgmiosTxIn + | NoCostModelForLanguage (Array String) + | InternalLedgerTypeConversionError String + | IllFormedExecutionBudget (Maybe ExecutionUnits) -derive instance Generic OgmiosScriptFailure _ -derive instance Newtype OgmiosScriptFailure _ +derive instance Generic ScriptFailure _ -instance Show OgmiosScriptFailure where +instance Show ScriptFailure where show = genericShow -newtype OgmiosTxEvaluationFailure = - OgmiosTxEvaluationFailure TxEvaluationFailure +-- The following cases are fine to fall through into unparsed error: +-- IncompatibleEra +-- NotEnoughSynced +-- CannotCreateEvaluationContext +data TxEvaluationFailure + = UnparsedError String + | AdditionalUtxoOverlap (Array OgmiosTxOutRef) + | ScriptFailures (Map RedeemerPointer (Array ScriptFailure)) -derive instance Generic OgmiosTxEvaluationFailure _ -derive instance Newtype OgmiosTxEvaluationFailure _ +derive instance Generic TxEvaluationFailure _ -instance Show OgmiosTxEvaluationFailure where +instance Show TxEvaluationFailure where show = genericShow -instance DecodeAeson OgmiosScriptFailure where - decodeAeson aeson = OgmiosScriptFailure <$> do +instance DecodeAeson ScriptFailure where + decodeAeson aeson = do err :: OgmiosError <- decodeAeson aeson let error = unwrap err errorData <- maybe (Left (AtKey "data" MissingValue)) pure error.data @@ -745,8 +661,8 @@ instance DecodeAeson OgmiosScriptFailure where _ -> Left $ TypeMismatch $ "Unknown ogmios error code: " <> show error.code -instance DecodeAeson OgmiosTxEvaluationFailure where - decodeAeson aeson = OgmiosTxEvaluationFailure <$> do +instance DecodeAeson TxEvaluationFailure where + decodeAeson aeson = do error :: OgmiosError <- decodeAeson aeson let code = (unwrap error).code errorData <- maybe (Left (AtKey "data" MissingValue)) pure @@ -773,9 +689,9 @@ instance DecodeAeson OgmiosTxEvaluationFailure where where parseElem elem = do - res :: { validator :: OgmiosRedeemerPtr, error :: OgmiosScriptFailure } <- + res :: { validator :: OgmiosRedeemerPtr, error :: ScriptFailure } <- decodeAeson elem - (_ /\ unwrap res.error) <$> decodeRedeemerPointer res.validator + (_ /\ res.error) <$> decodeRedeemerPointer res.validator collectIntoMap :: forall k v. Ord k => Array (k /\ v) -> Map k (List v) collectIntoMap = foldl @@ -1002,6 +918,20 @@ derive instance Newtype AdditionalUtxoSet _ derive newtype instance Show AdditionalUtxoSet +-- Ogmios tx input +type OgmiosTxOutRef = + { txId :: String + , index :: UInt + } + +type OgmiosTxOut = + { address :: OgmiosAddress + , value :: Value + , datumHash :: Maybe String + , datum :: Maybe String + , script :: Maybe ScriptRef + } + type OgmiosUtxoMap = Map OgmiosTxOutRef OgmiosTxOut instance EncodeAeson AdditionalUtxoSet where @@ -1094,17 +1024,90 @@ aesonArray -> Either JsonDecodeError a aesonArray = caseAesonArray (Left (TypeMismatch "Expected Array")) --- Helper that decodes a string -aesonString - :: forall (a :: Type) - . (String -> Either JsonDecodeError a) +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +ogmiosPostRequest + :: Aeson -- ^ JSON-RPC request body + -> QueryM (Either Affjax.Error (Affjax.Response String)) +ogmiosPostRequest body = do + config <- asks (_.ogmiosConfig <<< _.config) + logTrace' $ "sending ogmios HTTP request: " <> show body + liftAff $ ogmiosPostRequestAff config body + +ogmiosPostRequestAff + :: ServerConfig -> Aeson - -> Either JsonDecodeError a -aesonString = caseAesonString (Left (TypeMismatch "Expected String")) + -> Aff (Either Affjax.Error (Affjax.Response String)) +ogmiosPostRequestAff = ogmiosPostRequestRetryAff (Milliseconds 1000.0) + +ogmiosPostRequestRetryAff + :: Milliseconds + -> ServerConfig + -> Aeson + -> Aff (Either Affjax.Error (Affjax.Response String)) +ogmiosPostRequestRetryAff delayMs config body = do + let + req = Affjax.defaultRequest + { method = Left POST + , url = mkHttpUrl config + , headers = + [ Affjax.RequestHeader.RequestHeader "Content-Type" + "application/json" + ] + , content = Just $ Affjax.RequestBody.String $ stringifyAeson body + , responseFormat = Affjax.ResponseFormat.string + } + + result <- Affjax.request req + + if result ^? _Right <<< to _.status == Just (StatusCode 503) then + delay delayMs *> + ogmiosPostRequestRetryAff (Milliseconds (unwrap delayMs * 2.0)) config + body + + else pure result + +handleAffjaxOgmiosResponse + :: forall (result :: Type) + . DecodeOgmios result + => Either Affjax.Error (Affjax.Response String) + -> Either OgmiosDecodeError result +handleAffjaxOgmiosResponse (Left affjaxError) = + Left (ClientErrorResponse $ ClientHttpError affjaxError) +handleAffjaxOgmiosResponse + (Right { status: Affjax.StatusCode.StatusCode statusCode, body }) + | statusCode < 200 || statusCode > 299 = + Left $ ClientErrorResponse $ ClientHttpResponseError (wrap statusCode) $ + ServiceOtherError body + | otherwise = do + aeson <- lmap ResultDecodingError + $ parseJsonStringToAeson body + decodeOgmios aeson + +ogmiosErrorHandler + :: forall a m + . MonadAff m + => MonadThrow Error m + => m (Either OgmiosDecodeError a) + -> m a +ogmiosErrorHandler fun = do + resp <- fun + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure val + +ogmiosErrorHandlerWithArg + :: forall a m b + . MonadAff m + => MonadThrow Error m + => (a -> m (Either OgmiosDecodeError b)) + -> a + -> m b +ogmiosErrorHandlerWithArg fun arg = do + resp <- fun arg + case resp of + Left err -> throwError $ error $ pprintOgmiosDecodeError err + Right val -> pure val --- Helper that decodes a null -aesonNull - :: forall (a :: Type) - . Aeson - -> Either JsonDecodeError Unit -aesonNull = caseAesonNull (Left (TypeMismatch "Expected Null")) pure diff --git a/src/Internal/QueryM/OgmiosWebsocket/Dispatcher.purs b/src/Internal/QueryM/Ogmios/Dispatcher.purs similarity index 98% rename from src/Internal/QueryM/OgmiosWebsocket/Dispatcher.purs rename to src/Internal/QueryM/Ogmios/Dispatcher.purs index 312397b183..b5b7a08f1d 100644 --- a/src/Internal/QueryM/OgmiosWebsocket/Dispatcher.purs +++ b/src/Internal/QueryM/Ogmios/Dispatcher.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher +module Ctl.Internal.QueryM.Ogmios.Dispatcher ( DispatchError(JsonError, FaultError, ListenerCancelled) , Dispatcher , GenericPendingRequests diff --git a/src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.js b/src/Internal/QueryM/Ogmios/JsWebSocket.js similarity index 100% rename from src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.js rename to src/Internal/QueryM/Ogmios/JsWebSocket.js diff --git a/src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.purs b/src/Internal/QueryM/Ogmios/JsWebSocket.purs similarity index 96% rename from src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.purs rename to src/Internal/QueryM/Ogmios/JsWebSocket.purs index c73aa3609f..bd06252288 100644 --- a/src/Internal/QueryM/OgmiosWebsocket/JsWebSocket.purs +++ b/src/Internal/QueryM/Ogmios/JsWebSocket.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket +module Ctl.Internal.QueryM.Ogmios.JsWebSocket ( JsWebSocket , ListenerRef , Url diff --git a/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs similarity index 98% rename from src/Internal/QueryM/OgmiosWebsocket/Mempool.purs rename to src/Internal/QueryM/Ogmios/Mempool.purs index ca9268b7f0..686d8ee206 100644 --- a/src/Internal/QueryM/OgmiosWebsocket/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.OgmiosWebsocket.Mempool +module Ctl.Internal.QueryM.Ogmios.Mempool ( acquireMempoolSnapshotAff , mempoolSnapshotHasTxAff , mempoolSnapshotNextTxAff @@ -51,7 +51,31 @@ import Ctl.Internal.QueryM.JsonRpc2 , ogmiosDecodeErrorToError ) import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Dispatcher + ( DispatchError(JsonError) + , Dispatcher + , GenericPendingRequests + , PendingRequests + , PendingSubmitTxRequests + , RequestBody + , WebsocketDispatch + , mkWebsocketDispatch + , newDispatcher + , newPendingRequests + ) +import Ctl.Internal.QueryM.Ogmios.JsWebSocket + ( JsWebSocket + , Url + , _mkWebSocket + , _onWsConnect + , _onWsError + , _onWsMessage + , _removeOnWsError + , _wsClose + , _wsFinalize + , _wsSend + ) +import Ctl.Internal.QueryM.Ogmios.Types ( AdditionalUtxoSet , DelegationsAndRewardsR , HasTxR @@ -62,7 +86,7 @@ import Ctl.Internal.QueryM.Ogmios , ReleasedMempool , StakePoolsQueryArgument ) -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Types ( ChainTipQR , CurrentEpoch , HasTxR @@ -76,30 +100,6 @@ import Ctl.Internal.QueryM.Ogmios , SubmitTxR , submitSuccessPartialResp ) as Ogmios -import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher - ( DispatchError(JsonError) - , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests - , RequestBody - , WebsocketDispatch - , mkWebsocketDispatch - , newDispatcher - , newPendingRequests - ) -import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket - ( JsWebSocket - , Url - , _mkWebSocket - , _onWsConnect - , _onWsError - , _onWsMessage - , _removeOnWsError - , _wsClose - , _wsFinalize - , _wsSend - ) import Ctl.Internal.QueryM.UniqueId (ListenerId) import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) import Data.Bifunctor (lmap) diff --git a/src/Internal/QueryM/OgmiosWebsocket/Queries.purs b/src/Internal/QueryM/Ogmios/Queries.purs similarity index 92% rename from src/Internal/QueryM/OgmiosWebsocket/Queries.purs rename to src/Internal/QueryM/Ogmios/Queries.purs index 84887fb12c..bf5654d006 100644 --- a/src/Internal/QueryM/OgmiosWebsocket/Queries.purs +++ b/src/Internal/QueryM/Ogmios/Queries.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.OgmiosWebsocket.Queries +module Ctl.Internal.QueryM.Ogmios.Queries ( module ExportDispatcher , module ExportServerConfig , ClusterSetup @@ -10,7 +10,7 @@ module Ctl.Internal.QueryM.OgmiosWebsocket.Queries import Prelude import Cardano.Wallet.Key (PrivatePaymentKey, PrivateStakeKey) -import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher +import Ctl.Internal.QueryM.Ogmios.Dispatcher ( DispatchError(JsonError, FaultError, ListenerCancelled) , Dispatcher , GenericPendingRequests @@ -23,7 +23,7 @@ import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher , newDispatcher , newPendingRequests ) as ExportDispatcher -import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool (OgmiosWebSocket) +import Ctl.Internal.QueryM.Ogmios.Mempool (OgmiosWebSocket) import Ctl.Internal.ServerConfig ( Host , ServerConfig diff --git a/src/Internal/QueryM/OgmiosHttp.purs b/src/Internal/QueryM/Ogmios/Types.purs similarity index 66% rename from src/Internal/QueryM/OgmiosHttp.purs rename to src/Internal/QueryM/Ogmios/Types.purs index 631d434cd4..90972784e8 100644 --- a/src/Internal/QueryM/OgmiosHttp.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -1,15 +1,33 @@ -module Ctl.Internal.QueryM.OgmiosHttp - ( getSystemStartTime - , aesonObject - , getChainTip - , currentEpoch - , submitTxOgmios - , poolParameters +-- | Provides types and instances to create Ogmios requests and decode +-- | its responses. +module Ctl.Internal.QueryM.Ogmios.Types + ( ChainOrigin(ChainOrigin) + , ChainPoint + , ChainTipQR(CtChainOrigin, CtChainPoint) + , CurrentEpoch(CurrentEpoch) + , DelegationsAndRewardsR(DelegationsAndRewardsR) + , MempoolSizeAndCapacity(MempoolSizeAndCapacity) + , MempoolSnapshotAcquired + , MempoolTransaction(MempoolTransaction) + , OgmiosBlockHeaderHash(OgmiosBlockHeaderHash) + , OgmiosProtocolParameters(OgmiosProtocolParameters) + , PParamRational(PParamRational) + , PoolParameters + , PoolParametersR(PoolParametersR) + , ReleasedMempool(ReleasedMempool) + , AdditionalUtxoSet(AdditionalUtxoSet) + , OgmiosUtxoMap + , OgmiosEraSummaries(OgmiosEraSummaries) + , OgmiosSystemStart(OgmiosSystemStart) + , SubmitTxR(SubmitTxSuccess, SubmitFail) , StakePoolsQueryArgument(StakePoolsQueryArgument) - , delegationsAndRewards - , eraSummaries - , getProtocolParameters - , evaluateTxOgmios + , HasTxR(HasTxR) + , MaybeMempoolTransaction(MaybeMempoolTransaction) + , OgmiosTxEvaluationR(OgmiosTxEvaluationR) + , aesonObject + , submitSuccessPartialResp + , parseIpv6String + , rationalToSubcoin ) where import Prelude @@ -18,46 +36,55 @@ import Aeson ( class DecodeAeson , class EncodeAeson , Aeson - , JsonDecodeError(TypeMismatch, MissingValue, AtKey) + , JsonDecodeError(AtKey, TypeMismatch, UnexpectedValue, MissingValue) , caseAesonArray + , caseAesonNull , caseAesonObject , caseAesonString , decodeAeson , encodeAeson , fromArray + , fromString , getField , isNull - , parseJsonStringToAeson , stringifyAeson + , (.:) , (.:?) ) -import Aeson as Aeson -import Affjax (Error, Response, defaultRequest) as Affjax -import Affjax.RequestBody as Affjax.RequestBody -import Affjax.RequestHeader as Affjax.RequestHeader -import Affjax.ResponseFormat (string) as Affjax.ResponseFormat -import Affjax.StatusCode (StatusCode(StatusCode)) -import Affjax.StatusCode as Affjax.StatusCode -import Cardano.AsCbor (encodeCbor) -import Cardano.Provider.Error - ( ClientError(ClientHttpError, ClientHttpResponseError) - , ServiceError(ServiceOtherError) +import Cardano.AsCbor (decodeCbor, encodeCbor) +import Cardano.Provider.TxEvaluation + ( ExecutionUnits + , OgmiosTxId + , OgmiosTxOut + , OgmiosTxOutRef + , RedeemerPointer + , ScriptFailure + ( InternalLedgerTypeConversionError + , NoCostModelForLanguage + , UnknownInputReferencedByRedeemer + , MissingRequiredDatums + , ExtraRedeemers + , NonScriptInputReferencedByRedeemer + , ValidatorFailed + , MissingRequiredScripts + ) + , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) + , TxEvaluationR(TxEvaluationR) + , TxEvaluationResult(TxEvaluationResult) ) -import Cardano.Provider.TxEvaluation as Provider -import Cardano.Serialization.Lib (fromBytes) +import Cardano.Serialization.Lib (fromBytes, ipv4_new) import Cardano.Types - ( Bech32String - , BigNum(BigNum) + ( BigNum(BigNum) , Language(PlutusV3, PlutusV2, PlutusV1) , RedeemerTag + , VRFKeyHash(VRFKeyHash) ) import Cardano.Types.AssetName (unAssetName) import Cardano.Types.BigNum (BigNum) -import Cardano.Types.BigNum (fromBigInt) as BigNum -import Cardano.Types.CborBytes (CborBytes) -import Cardano.Types.Chain as Chain +import Cardano.Types.BigNum (fromBigInt, fromString) as BigNum import Cardano.Types.Coin (Coin(Coin)) import Cardano.Types.CostModel (CostModel(CostModel)) +import Cardano.Types.Ed25519KeyHash (Ed25519KeyHash) import Cardano.Types.EraSummaries ( EraSummaries(EraSummaries) , EraSummary(EraSummary) @@ -67,6 +94,8 @@ import Cardano.Types.EraSummaries import Cardano.Types.ExUnitPrices (ExUnitPrices(ExUnitPrices)) import Cardano.Types.ExUnits (ExUnits(ExUnits)) import Cardano.Types.Int as Cardano +import Cardano.Types.Ipv4 (Ipv4(Ipv4)) +import Cardano.Types.Ipv6 (Ipv6) import Cardano.Types.NativeScript ( NativeScript ( ScriptPubkey @@ -78,43 +107,31 @@ import Cardano.Types.NativeScript ) ) import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) +import Cardano.Types.PoolMetadata (PoolMetadata(PoolMetadata)) import Cardano.Types.PoolPubKeyHash (PoolPubKeyHash) import Cardano.Types.RedeemerTag ( RedeemerTag(Spend, Mint, Cert, Reward, Vote, Propose) ) as RedeemerTag -import Cardano.Types.ScriptHash (ScriptHash) +import Cardano.Types.Relay + ( Relay(SingleHostAddr, SingleHostName, MultiHostName) + ) +import Cardano.Types.RewardAddress (RewardAddress) +import Cardano.Types.RewardAddress as RewardAddress import Cardano.Types.ScriptRef (ScriptRef(NativeScriptRef, PlutusScriptRef)) import Cardano.Types.Slot (Slot(Slot)) import Cardano.Types.TransactionHash (TransactionHash) +import Cardano.Types.URL (URL(URL)) import Cardano.Types.UnitInterval (UnitInterval(UnitInterval)) import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) -import Contract.Log (logTrace') -import Control.Monad.Error.Class (class MonadThrow, throwError) -import Control.Monad.Reader.Class (asks) -import Ctl.Internal.Affjax (request) as Affjax +import Control.Alt ((<|>)) +import Control.Alternative (guard) import Ctl.Internal.Helpers (encodeMap, showWithParens) -import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 ( class DecodeOgmios - , OgmiosDecodeError(ClientErrorResponse, ResultDecodingError) , OgmiosError , decodeErrorOrResult - , decodeOgmios , decodeResult - , pprintOgmiosDecodeError ) -import Ctl.Internal.QueryM.Ogmios - ( AdditionalUtxoSet - , CurrentEpoch - , DelegationsAndRewardsR(DelegationsAndRewardsR) - , OgmiosEraSummaries - , OgmiosProtocolParameters - , OgmiosSystemStart - , OgmiosTxEvaluationR - , PoolParametersR - , SubmitTxR - ) as Ogmios -import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) import Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) ) @@ -125,15 +142,15 @@ import Ctl.Internal.Types.SystemStart , sysStartFromOgmiosTimestamp , sysStartToOgmiosTimestamp ) +import Data.Argonaut.Encode.Encoders as Argonaut import Data.Array (catMaybes) -import Data.Array (fromFoldable) as Array +import Data.Array (fromFoldable, length, replicate) as Array import Data.Bifunctor (lmap) -import Data.ByteArray (byteArrayToHex, hexToByteArray) +import Data.ByteArray (byteArrayFromIntArray, byteArrayToHex, hexToByteArray) import Data.Either (Either(Left, Right), either, note) -import Data.Foldable (foldl) +import Data.Foldable (fold, foldl) import Data.Generic.Rep (class Generic) -import Data.HTTP.Method (Method(POST)) -import Data.Lens (_Right, to, (^?)) +import Data.Int (fromString) as Int import Data.List (List) import Data.List as List import Data.Map (Map) @@ -141,173 +158,22 @@ import Data.Map as Map import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe) import Data.Newtype (class Newtype, unwrap, wrap) import Data.Show.Generic (genericShow) -import Data.String (Pattern(Pattern)) +import Data.String (Pattern(Pattern), Replacement(Replacement)) +import Data.String (replaceAll) as String import Data.String.Common (split) as String -import Data.Time.Duration (Milliseconds(Milliseconds)) +import Data.String.Utils as StringUtils import Data.Traversable (for, traverse) import Data.Tuple (Tuple(Tuple)) import Data.Tuple.Nested (type (/\), (/\)) import Data.UInt (UInt) -import Effect.Aff (Aff, delay) -import Effect.Aff.Class (class MonadAff, liftAff) -import Effect.Exception (Error, error) import Foreign.Object (Object) import Foreign.Object as Object import JS.BigInt as BigInt import Untagged.TypeCheck (class HasRuntimeType) import Untagged.Union (type (|+|), toEither1) -eraSummaries :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosEraSummaries) -eraSummaries = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "eraSummaries" - , method: "queryLedgerState/eraSummaries" - } - ) - -getSystemStartTime :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosSystemStart) -getSystemStartTime = do - let - body = Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "getSystemStartTime" - , method: "queryNetwork/startTime" - } - handleAffjaxOgmiosResponse <$> ogmiosPostRequest body - -getProtocolParameters - :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosProtocolParameters) -getProtocolParameters = do - let - body = Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "getProtocolParameters" - , method: "queryLedgerState/protocolParameters" - } - handleAffjaxOgmiosResponse <$> ogmiosPostRequest body - -getChainTip :: QueryM Chain.Tip -getChainTip = do - ogmiosChainTipToTip <$> ogmiosErrorHandler chainTip - where - ogmiosChainTipToTip :: ChainTipQR -> Chain.Tip - ogmiosChainTipToTip = case _ of - CtChainOrigin _ -> Chain.TipAtGenesis - CtChainPoint { slot, id } -> Chain.Tip $ wrap - { slot, blockHeaderHash: wrap $ unwrap id } - - chainTip :: QueryM (Either OgmiosDecodeError ChainTipQR) - chainTip = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "getChainTip" - , method: "queryNetwork/tip" - } - ) - -currentEpoch :: QueryM (Either OgmiosDecodeError Ogmios.CurrentEpoch) -currentEpoch = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "currentEpoch" - , method: "queryLedgerState/epoch" - } - ) - -submitTxOgmios :: TransactionHash -> CborBytes -> QueryM Ogmios.SubmitTxR -submitTxOgmios txHash tx = ogmiosErrorHandlerWithArg submitTx - (txHash /\ tx) - where - submitTx - :: TransactionHash /\ CborBytes - -> QueryM (Either OgmiosDecodeError Ogmios.SubmitTxR) - submitTx (_ /\ cbor) = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "submitTxOgmios" - , method: "submitTransaction" - , params: - { transaction: - { cbor: byteArrayToHex (unwrap cbor) - } - } - } - ) - -poolParameters - :: StakePoolsQueryArgument - -> QueryM (Either OgmiosDecodeError Ogmios.PoolParametersR) -poolParameters stakePools = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "poolParameters" - , method: "queryLedgerState/stakePools" - , params: stakePools - } - ) - -delegationsAndRewards - :: Array String -- ^ A list of reward account bech32 strings - -> QueryM (Either OgmiosDecodeError Ogmios.DelegationsAndRewardsR) -delegationsAndRewards rewardAccounts = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "delegationsAndRewards" - , method: "queryLedgerState/rewardAccountSummaries" - , params: - { query: - { delegationsAndRewards: rewardAccounts } - } - } - ) - -evaluateTxOgmios - :: CborBytes -> Ogmios.AdditionalUtxoSet -> QueryM Provider.TxEvaluationR -evaluateTxOgmios cbor additionalUtxos = unwrap <$> ogmiosErrorHandlerWithArg - evaluateTx - (cbor /\ additionalUtxos) - where - evaluateTx - :: CborBytes /\ Ogmios.AdditionalUtxoSet - -> QueryM (Either OgmiosDecodeError Ogmios.OgmiosTxEvaluationR) - evaluateTx (cbor_ /\ utxoqr) = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "evaluateTxOgmios" - , method: "evaluateTransaction" - , params: - { transaction: { cbor: byteArrayToHex $ unwrap cbor_ } - , additionalUtxo: utxoqr - } - } - ) - -instance DecodeOgmios TxEvaluationR where - decodeOgmios = decodeErrorOrResult - { parseError: map (wrap <<< Left) <<< decodeAeson } - { parseResult: map (wrap <<< Right) <<< decodeAeson } - --- Response parsing -------------------------------------------------------------------------------- -type OgmiosAddress = Bech32String - --------------------------------------------------------------------------------- -- Local Tx Monitor Query Response & Parsing -------------------------------------------------------------------------------- @@ -318,8 +184,100 @@ derive instance Newtype HasTxR _ instance DecodeOgmios HasTxR where decodeOgmios = decodeResult (map HasTxR <<< decodeAeson) +newtype MempoolSnapshotAcquired = AwaitAcquired Slot + +instance Show MempoolSnapshotAcquired where + show (AwaitAcquired slot) = "(AwaitAcquired " <> show slot <> ")" + +instance DecodeAeson MempoolSnapshotAcquired where + decodeAeson = + -- todo: ignoring "acquired": "mempool" + map AwaitAcquired <<< aesonObject (flip getField "slot") + +instance DecodeOgmios MempoolSnapshotAcquired where + decodeOgmios = decodeResult decodeAeson + +-- | The acquired snapshot’s size (in bytes), number of transactions, and capacity +-- | (in bytes). +newtype MempoolSizeAndCapacity = MempoolSizeAndCapacity + { capacity :: Prim.Int + , currentSize :: Prim.Int + , numberOfTxs :: Prim.Int + } + +derive instance Generic MempoolSizeAndCapacity _ +derive instance Newtype MempoolSizeAndCapacity _ + +instance Show MempoolSizeAndCapacity where + show = genericShow + +instance DecodeAeson MempoolSizeAndCapacity where + decodeAeson = aesonObject \o -> do + capacity <- getField o "maxCapacity" >>= flip getField "bytes" + currentSize <- getField o "currentSize" >>= flip getField "bytes" + numberOfTxs <- getField o "transactions" >>= flip getField "count" + pure $ wrap { capacity, currentSize, numberOfTxs } + +instance DecodeOgmios MempoolSizeAndCapacity where + decodeOgmios = decodeResult decodeAeson + +newtype MempoolTransaction = MempoolTransaction + { id :: OgmiosTxId + , raw :: String -- hex encoded transaction cbor + } + +derive instance Generic MempoolTransaction _ +derive instance Newtype MempoolTransaction _ + +newtype MaybeMempoolTransaction = MaybeMempoolTransaction + (Maybe MempoolTransaction) + +instance DecodeAeson MaybeMempoolTransaction where + decodeAeson aeson = do + { transaction: tx } :: { transaction :: Aeson } <- decodeAeson aeson + res <- + ( do + tx' :: { id :: String, cbor :: String } <- decodeAeson tx + pure $ Just $ MempoolTransaction { id: tx'.id, raw: tx'.cbor } + ) <|> + ( do + aesonNull tx + pure Nothing + ) + pure $ MaybeMempoolTransaction $ res + +derive instance Newtype MaybeMempoolTransaction _ + +instance DecodeOgmios MaybeMempoolTransaction where + decodeOgmios = decodeResult decodeAeson + +data ReleasedMempool = ReleasedMempool + +derive instance Generic ReleasedMempool _ + +instance Show ReleasedMempool where + show = genericShow + +instance DecodeAeson ReleasedMempool where + decodeAeson = aesonObject \o -> do + released <- o .: "released" + flip aesonString released $ \s -> + if s == "mempool" then + pure $ ReleasedMempool + else + Left (UnexpectedValue $ Argonaut.encodeString s) + +instance DecodeOgmios ReleasedMempool where + decodeOgmios = decodeResult decodeAeson + ---------------- TX SUBMISSION QUERY RESPONSE & PARSING +submitSuccessPartialResp + :: TransactionHash + -> { result :: { transaction :: { id :: TransactionHash } } } +submitSuccessPartialResp txHash = + { "result": { "transaction": { "id": txHash } } } + data SubmitTxR = SubmitTxSuccess TransactionHash | SubmitFail OgmiosError @@ -435,8 +393,8 @@ instance DecodeAeson OgmiosEraSummaries where pure $ wrap { epochLength, slotLength, safeZone } instance EncodeAeson OgmiosEraSummaries where - encodeAeson (OgmiosEraSummaries (EraSummaries es)) = - fromArray $ map encodeEraSummary es + encodeAeson (OgmiosEraSummaries (EraSummaries eraSummaries)) = + fromArray $ map encodeEraSummary eraSummaries where encodeEraSummaryTime :: EraSummaryTime -> Aeson encodeEraSummaryTime (EraSummaryTime { time, slot, epoch }) = @@ -502,35 +460,189 @@ instance EncodeAeson StakePoolsQueryArgument where ) (unwrap a) ----------------- TX EVALUATION QUERY RESPONSE & PARSING +---------------- POOL PARAMETERS QUERY RESPONSE & PARSING + +type PoolParameters = + { vrfKeyhash :: VRFKeyHash + -- needed to prove that the pool won the lottery + , pledge :: BigNum + , cost :: BigNum -- >= pparams.minPoolCost + , margin :: UnitInterval -- proportion that goes to the reward account + , rewardAccount :: RewardAddress + , poolOwners :: Array Ed25519KeyHash + -- payment key hashes that contribute to pledge amount + , relays :: Array Relay + , poolMetadata :: Maybe PoolMetadata + } + +newtype PoolParametersR = PoolParametersR (Map PoolPubKeyHash PoolParameters) + +derive instance Newtype PoolParametersR _ +derive instance Generic PoolParametersR _ + +instance Show PoolParametersR where + show = genericShow -type RedeemerPointer = { redeemerTag :: RedeemerTag, redeemerIndex :: UInt } +instance DecodeAeson PoolParametersR where + decodeAeson aeson = do + obj :: Object (Object Aeson) <- decodeAeson aeson + kvs <- for (Object.toUnfoldable obj :: Array _) \(Tuple k objParams) -> do + poolPkh <- decodeAeson $ fromString k + poolParams <- decodePoolParameters objParams + pure $ poolPkh /\ poolParams + pure $ PoolParametersR $ Map.fromFoldable kvs + +instance DecodeOgmios PoolParametersR where + decodeOgmios = decodeResult decodeAeson + +decodePoolParameters :: Object Aeson -> Either JsonDecodeError PoolParameters +decodePoolParameters objParams = do + vrfKeyhash <- decodeVRFKeyHash =<< objParams .: "vrfVerificationKeyHash" + pledge <- objParams .: "pledge" >>= aesonObject \obj -> + obj .: "ada" >>= flip getField "lovelace" + cost <- objParams .: "cost" >>= aesonObject \obj -> + obj .: "ada" >>= flip getField "lovelace" + margin <- decodeUnitInterval =<< objParams .: "margin" + rewardAccount <- objParams .: "rewardAccount" >>= + RewardAddress.fromBech32 >>> note (TypeMismatch "RewardAddress") + poolOwners <- objParams .: "owners" + relayArr <- objParams .: "relays" + relays <- for relayArr decodeRelay + poolMetadata <- objParams .:? "metadata" >>= traverse decodePoolMetadata + pure + { vrfKeyhash + , pledge + , cost + , margin + , rewardAccount + , poolOwners + , relays + , poolMetadata + } + +decodeVRFKeyHash :: Aeson -> Either JsonDecodeError VRFKeyHash +decodeVRFKeyHash = aesonString $ \vrfKeyhashHex -> do + vrfKeyhashBytes <- note (TypeMismatch "VRFKeyHash") $ hexToByteArray + vrfKeyhashHex + note (TypeMismatch "VRFKeyHash") $ VRFKeyHash <$> fromBytes vrfKeyhashBytes + +decodeUnitInterval :: Aeson -> Either JsonDecodeError UnitInterval +decodeUnitInterval aeson = do + str <- decodeAeson aeson + case String.split (Pattern "/") str of + [ num, den ] -> do + numerator <- note (TypeMismatch "BigNum") $ BigNum.fromString num + denominator <- note (TypeMismatch "BigNum") $ BigNum.fromString den + pure $ UnitInterval + { numerator + , denominator + } + _ -> Left $ TypeMismatch "UnitInterval" + +decodeIpv4 :: Aeson -> Either JsonDecodeError Ipv4 +decodeIpv4 aeson = do + str <- decodeAeson aeson + case String.split (Pattern ".") str of + bs@[ _, _, _, _ ] -> do + ints <- for bs $ + note (TypeMismatch "Ipv4") <<< Int.fromString + Ipv4 <<< ipv4_new <$> note (TypeMismatch "Ipv4") + (byteArrayFromIntArray ints) + _ -> Left $ TypeMismatch "Ipv4" + +decodeIpv6 :: Aeson -> Either JsonDecodeError Ipv6 +decodeIpv6 aeson = do + decodeAeson aeson >>= parseIpv6String >>> note (TypeMismatch "Ipv6") + +parseIpv6String :: String -> Maybe Ipv6 +parseIpv6String str = do + let + parts = String.split (Pattern ":") str + partsFixed = + if Array.length parts < 8 then + -- Normalize double colon + -- see https://ipcisco.com/lesson/ipv6-address/ + do + part <- parts + if part == "" then + Array.replicate (8 - Array.length parts + 1) "" + else + pure part + else + parts + guard (Array.length partsFixed == 8) + let + padded = String.replaceAll (Pattern " ") (Replacement "0") $ fold $ + partsFixed + <#> StringUtils.padStart 4 + decodeCbor <<< wrap =<< hexToByteArray padded + +decodeRelay :: Aeson -> Either JsonDecodeError Relay +decodeRelay aeson = do + obj <- decodeAeson aeson + let + decodeSingleHostAddr = do + port <- obj .:? "port" + ipv4 <- obj .:? "ipv4" >>= traverse decodeIpv4 + ipv6 <- obj .:? "ipv6" >>= traverse decodeIpv6 + pure $ SingleHostAddr { port, ipv4, ipv6 } + decodeSingleHostName = do + port <- obj .: "port" + dnsName <- obj .: "hostname" + pure $ SingleHostName { port, dnsName } + decodeMultiHostName = do + dnsName <- obj .: "hostname" + pure $ MultiHostName { dnsName } + decodeSingleHostName <|> decodeSingleHostAddr <|> decodeMultiHostName + +decodePoolMetadata :: Aeson -> Either JsonDecodeError PoolMetadata +decodePoolMetadata aeson = do + obj <- decodeAeson aeson + hash <- obj .: "hash" >>= + (hexToByteArray >>> map wrap >=> decodeCbor) >>> + note (TypeMismatch "PoolMetadataHash") + url <- obj .: "url" <#> URL + pure $ PoolMetadata { hash, url } -type ExecutionUnits = { memory :: BigNum, steps :: BigNum } +---------------- TX EVALUATION QUERY RESPONSE & PARSING type OgmiosRedeemerPtr = { index :: UInt, purpose :: String } -newtype TxEvaluationR = TxEvaluationR - (Either TxEvaluationFailure TxEvaluationResult) +newtype OgmiosTxEvaluationR = OgmiosTxEvaluationR TxEvaluationR -derive instance Newtype TxEvaluationR _ -derive instance Generic TxEvaluationR _ +derive instance Newtype OgmiosTxEvaluationR _ +derive instance Generic OgmiosTxEvaluationR _ -instance Show TxEvaluationR where +instance Show OgmiosTxEvaluationR where show = genericShow -newtype TxEvaluationResult = TxEvaluationResult - (Map RedeemerPointer ExecutionUnits) +instance DecodeOgmios OgmiosTxEvaluationR where + decodeOgmios = + decodeErrorOrResult + { parseError: + map + ( \(f :: OgmiosTxEvaluationFailure) -> + f # unwrap # Left # wrap # wrap + ) <<< decodeAeson + } + { parseResult: + map + ( \(r :: OgmiosTxEvaluationResult) -> r # unwrap # Right # wrap # + wrap + ) <<< decodeAeson + } + +newtype OgmiosTxEvaluationResult = OgmiosTxEvaluationResult TxEvaluationResult -derive instance Newtype TxEvaluationResult _ -derive instance Generic TxEvaluationResult _ +derive instance Newtype OgmiosTxEvaluationResult _ +derive instance Generic OgmiosTxEvaluationResult _ -instance Show TxEvaluationResult where +instance Show OgmiosTxEvaluationResult where show = genericShow -instance DecodeAeson TxEvaluationResult where +instance DecodeAeson OgmiosTxEvaluationResult where decodeAeson = aesonArray $ \array -> do - TxEvaluationResult <<< Map.fromFoldable <$> + OgmiosTxEvaluationResult <<< TxEvaluationResult <<< Map.fromFoldable <$> traverse decodeRdmrPtrExUnitsItem array where @@ -566,53 +678,25 @@ redeemerTagFromString = case _ of "propose" -> Just RedeemerTag.Propose _ -> Nothing -type OgmiosDatum = String -type OgmiosScript = String -type OgmiosTxId = String -type OgmiosTxIn = { txId :: OgmiosTxId, index :: Prim.Int } - --- | Reason a script failed. --- --- The type definition is a least common denominator between Ogmios v6 format used by ogmios backend --- and ogmios v5.6 format used by blockfrost backend -data ScriptFailure - = ExtraRedeemers (Array RedeemerPointer) - | MissingRequiredDatums - { missing :: (Array OgmiosDatum) - , provided :: Maybe (Array OgmiosDatum) - } - | MissingRequiredScripts - { missing :: Array RedeemerPointer - , resolved :: Maybe (Map RedeemerPointer ScriptHash) - } - | ValidatorFailed { error :: String, traces :: Array String } - | UnknownInputReferencedByRedeemer (Array OgmiosTxIn) - | NonScriptInputReferencedByRedeemer OgmiosTxIn - | NoCostModelForLanguage (Array String) - | InternalLedgerTypeConversionError String - | IllFormedExecutionBudget (Maybe ExecutionUnits) +newtype OgmiosScriptFailure = OgmiosScriptFailure ScriptFailure -derive instance Generic ScriptFailure _ +derive instance Generic OgmiosScriptFailure _ +derive instance Newtype OgmiosScriptFailure _ -instance Show ScriptFailure where +instance Show OgmiosScriptFailure where show = genericShow --- The following cases are fine to fall through into unparsed error: --- IncompatibleEra --- NotEnoughSynced --- CannotCreateEvaluationContext -data TxEvaluationFailure - = UnparsedError String - | AdditionalUtxoOverlap (Array OgmiosTxOutRef) - | ScriptFailures (Map RedeemerPointer (Array ScriptFailure)) +newtype OgmiosTxEvaluationFailure = + OgmiosTxEvaluationFailure TxEvaluationFailure -derive instance Generic TxEvaluationFailure _ +derive instance Generic OgmiosTxEvaluationFailure _ +derive instance Newtype OgmiosTxEvaluationFailure _ -instance Show TxEvaluationFailure where +instance Show OgmiosTxEvaluationFailure where show = genericShow -instance DecodeAeson ScriptFailure where - decodeAeson aeson = do +instance DecodeAeson OgmiosScriptFailure where + decodeAeson aeson = OgmiosScriptFailure <$> do err :: OgmiosError <- decodeAeson aeson let error = unwrap err errorData <- maybe (Left (AtKey "data" MissingValue)) pure error.data @@ -661,8 +745,8 @@ instance DecodeAeson ScriptFailure where _ -> Left $ TypeMismatch $ "Unknown ogmios error code: " <> show error.code -instance DecodeAeson TxEvaluationFailure where - decodeAeson aeson = do +instance DecodeAeson OgmiosTxEvaluationFailure where + decodeAeson aeson = OgmiosTxEvaluationFailure <$> do error :: OgmiosError <- decodeAeson aeson let code = (unwrap error).code errorData <- maybe (Left (AtKey "data" MissingValue)) pure @@ -689,9 +773,9 @@ instance DecodeAeson TxEvaluationFailure where where parseElem elem = do - res :: { validator :: OgmiosRedeemerPtr, error :: ScriptFailure } <- + res :: { validator :: OgmiosRedeemerPtr, error :: OgmiosScriptFailure } <- decodeAeson elem - (_ /\ res.error) <$> decodeRedeemerPointer res.validator + (_ /\ unwrap res.error) <$> decodeRedeemerPointer res.validator collectIntoMap :: forall k v. Ord k => Array (k /\ v) -> Map k (List v) collectIntoMap = foldl @@ -918,20 +1002,6 @@ derive instance Newtype AdditionalUtxoSet _ derive newtype instance Show AdditionalUtxoSet --- Ogmios tx input -type OgmiosTxOutRef = - { txId :: String - , index :: UInt - } - -type OgmiosTxOut = - { address :: OgmiosAddress - , value :: Value - , datumHash :: Maybe String - , datum :: Maybe String - , script :: Maybe ScriptRef - } - type OgmiosUtxoMap = Map OgmiosTxOutRef OgmiosTxOut instance EncodeAeson AdditionalUtxoSet where @@ -1024,90 +1094,17 @@ aesonArray -> Either JsonDecodeError a aesonArray = caseAesonArray (Left (TypeMismatch "Expected Array")) --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- - -ogmiosPostRequest - :: Aeson -- ^ JSON-RPC request body - -> QueryM (Either Affjax.Error (Affjax.Response String)) -ogmiosPostRequest body = do - config <- asks (_.ogmiosConfig <<< _.config) - logTrace' $ "sending ogmios HTTP request: " <> show body - liftAff $ ogmiosPostRequestAff config body - -ogmiosPostRequestAff - :: ServerConfig - -> Aeson - -> Aff (Either Affjax.Error (Affjax.Response String)) -ogmiosPostRequestAff = ogmiosPostRequestRetryAff (Milliseconds 1000.0) - -ogmiosPostRequestRetryAff - :: Milliseconds - -> ServerConfig +-- Helper that decodes a string +aesonString + :: forall (a :: Type) + . (String -> Either JsonDecodeError a) -> Aeson - -> Aff (Either Affjax.Error (Affjax.Response String)) -ogmiosPostRequestRetryAff delayMs config body = do - let - req = Affjax.defaultRequest - { method = Left POST - , url = mkHttpUrl config - , headers = - [ Affjax.RequestHeader.RequestHeader "Content-Type" - "application/json" - ] - , content = Just $ Affjax.RequestBody.String $ stringifyAeson body - , responseFormat = Affjax.ResponseFormat.string - } - - result <- Affjax.request req - - if result ^? _Right <<< to _.status == Just (StatusCode 503) then - delay delayMs *> - ogmiosPostRequestRetryAff (Milliseconds (unwrap delayMs * 2.0)) config - body - - else pure result - -handleAffjaxOgmiosResponse - :: forall (result :: Type) - . DecodeOgmios result - => Either Affjax.Error (Affjax.Response String) - -> Either OgmiosDecodeError result -handleAffjaxOgmiosResponse (Left affjaxError) = - Left (ClientErrorResponse $ ClientHttpError affjaxError) -handleAffjaxOgmiosResponse - (Right { status: Affjax.StatusCode.StatusCode statusCode, body }) - | statusCode < 200 || statusCode > 299 = - Left $ ClientErrorResponse $ ClientHttpResponseError (wrap statusCode) $ - ServiceOtherError body - | otherwise = do - aeson <- lmap ResultDecodingError - $ parseJsonStringToAeson body - decodeOgmios aeson - -ogmiosErrorHandler - :: forall a m - . MonadAff m - => MonadThrow Error m - => m (Either OgmiosDecodeError a) - -> m a -ogmiosErrorHandler fun = do - resp <- fun - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure val - -ogmiosErrorHandlerWithArg - :: forall a m b - . MonadAff m - => MonadThrow Error m - => (a -> m (Either OgmiosDecodeError b)) - -> a - -> m b -ogmiosErrorHandlerWithArg fun arg = do - resp <- fun arg - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure val + -> Either JsonDecodeError a +aesonString = caseAesonString (Left (TypeMismatch "Expected String")) +-- Helper that decodes a null +aesonNull + :: forall (a :: Type) + . Aeson + -> Either JsonDecodeError Unit +aesonNull = caseAesonNull (Left (TypeMismatch "Expected Null")) pure diff --git a/src/Internal/QueryM/Pools.purs b/src/Internal/QueryM/Pools.purs index f6a27602f5..499cab5ced 100644 --- a/src/Internal/QueryM/Pools.purs +++ b/src/Internal/QueryM/Pools.purs @@ -17,8 +17,8 @@ import Control.Monad.Error.Class (throwError) import Ctl.Internal.Helpers (liftM) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) -import Ctl.Internal.QueryM.Ogmios (PoolParameters) -import Ctl.Internal.QueryM.OgmiosHttp as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios.Types (PoolParameters) import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) import Data.ByteArray (byteArrayToHex) import Data.Either (Either(Right, Left)) diff --git a/src/Internal/ServerConfig.purs b/src/Internal/ServerConfig.purs index 4e1479cf31..47ebef8173 100644 --- a/src/Internal/ServerConfig.purs +++ b/src/Internal/ServerConfig.purs @@ -16,7 +16,7 @@ module Ctl.Internal.ServerConfig import Prelude import Ctl.Internal.Helpers ((<>)) -import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket (Url) +import Ctl.Internal.QueryM.Ogmios.JsWebSocket (Url) import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.UInt (UInt) import Data.UInt as UInt diff --git a/src/Internal/Service/Blockfrost.purs b/src/Internal/Service/Blockfrost.purs index 55abf71c1b..a4de0ffb30 100644 --- a/src/Internal/Service/Blockfrost.purs +++ b/src/Internal/Service/Blockfrost.purs @@ -183,7 +183,7 @@ import Control.Monad.Reader.Trans (ReaderT, runReaderT) import Control.Parallel (parTraverse) import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Contract.ProviderBackend (BlockfrostBackend) -import Ctl.Internal.QueryM.Ogmios (AdditionalUtxoSet) +import Ctl.Internal.QueryM.Ogmios.Types (AdditionalUtxoSet) import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) import Ctl.Internal.Service.Helpers ( aesonArray diff --git a/src/Internal/Test/E2E/Feedback/Browser.purs b/src/Internal/Test/E2E/Feedback/Browser.purs index 64f3284d21..1f242deee7 100644 --- a/src/Internal/Test/E2E/Feedback/Browser.purs +++ b/src/Internal/Test/E2E/Feedback/Browser.purs @@ -13,7 +13,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, jsonToAeson, stringifyAeson) import Ctl.Internal.FfiHelpers (MaybeFfiHelper, maybeFfiHelper) import Ctl.Internal.Helpers (liftedM) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent) import Data.Argonaut (Json) import Data.Either (hush) diff --git a/src/Internal/Test/E2E/Feedback/Node.purs b/src/Internal/Test/E2E/Feedback/Node.purs index fcd1157abc..ab9b0cef3f 100644 --- a/src/Internal/Test/E2E/Feedback/Node.purs +++ b/src/Internal/Test/E2E/Feedback/Node.purs @@ -12,7 +12,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, parseJsonStringToAeson, stringifyAeson) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent(Failure, Success)) import Data.Array as Array import Data.Either (Either(Left), hush, note) diff --git a/src/Internal/Test/E2E/Route.purs b/src/Internal/Test/E2E/Route.purs index 2411aeec6d..fd71ab2d41 100644 --- a/src/Internal/Test/E2E/Route.purs +++ b/src/Internal/Test/E2E/Route.purs @@ -25,7 +25,7 @@ import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftMaybe) import Ctl.Internal.Contract.ProviderBackend (mkCtlBackendParams) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback.Browser (getClusterSetupRepeatedly) import Ctl.Internal.Test.E2E.Feedback.Hooks (addE2EFeedbackHooks) import Ctl.Internal.Wallet.Spec (WalletSpec(ConnectToGenericCip30)) diff --git a/src/Internal/Test/E2E/Runner.purs b/src/Internal/Test/E2E/Runner.purs index d38f769f91..75d9703fdc 100644 --- a/src/Internal/Test/E2E/Runner.purs +++ b/src/Internal/Test/E2E/Runner.purs @@ -24,7 +24,7 @@ import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Contract.Hooks (emptyHooks) import Ctl.Internal.Contract.ProviderBackend (ProviderBackend(CtlBackend)) import Ctl.Internal.Helpers (liftedM, unsafeFromJust, (<>)) -import Ctl.Internal.QueryM.OgmiosWebsocket.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) import Ctl.Internal.Test.E2E.Browser (withBrowser) import Ctl.Internal.Test.E2E.Feedback ( BrowserEvent(ConfirmAccess, Sign, Success, Failure) diff --git a/test/Ogmios/Aeson.purs b/test/Ogmios/Aeson.purs index 113e970b0d..a85e6c992d 100644 --- a/test/Ogmios/Aeson.purs +++ b/test/Ogmios/Aeson.purs @@ -15,13 +15,13 @@ import Ctl.Internal.QueryM.JsonRpc2 , OgmiosDecodeError(ErrorResponse) , decodeOgmios ) -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Types ( HasTxR , OgmiosTxEvaluationR , SubmitTxR , aesonObject ) -import Ctl.Internal.QueryM.Ogmios as O +import Ctl.Internal.QueryM.Ogmios.Types as O import Data.Array (catMaybes, groupAllBy, nubBy) import Data.Array.NonEmpty (NonEmptyArray, head, length, tail) import Data.Bifunctor (lmap) diff --git a/test/Ogmios/EvaluateTx.purs b/test/Ogmios/EvaluateTx.purs index 78012210b4..8d4417e819 100644 --- a/test/Ogmios/EvaluateTx.purs +++ b/test/Ogmios/EvaluateTx.purs @@ -17,7 +17,7 @@ import Ctl.Internal.QueryM.JsonRpc2 ( OgmiosDecodeError(ResultDecodingError) , decodeOgmios ) -import Ctl.Internal.QueryM.Ogmios (OgmiosTxEvaluationR) +import Ctl.Internal.QueryM.Ogmios.Types (OgmiosTxEvaluationR) import Data.Either (Either(Left, Right)) import Data.Map as Map import Data.Maybe (fromJust) diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index e8e6c229e8..c9d59160b2 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -8,11 +8,11 @@ import Aeson (class EncodeAeson, Aeson, encodeAeson, stringifyAeson) import Control.Parallel (parTraverse) import Ctl.Internal.Helpers (logString) import Ctl.Internal.QueryM.JsonRpc2 (class DecodeOgmios, JsonRpc2Call) -import Ctl.Internal.QueryM.OgmiosWebsocket.Dispatcher +import Ctl.Internal.QueryM.Ogmios.Dispatcher ( WebsocketDispatch , mkWebsocketDispatch ) -import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket +import Ctl.Internal.QueryM.Ogmios.JsWebSocket ( _mkWebSocket , _onWsConnect , _onWsError @@ -20,7 +20,7 @@ import Ctl.Internal.QueryM.OgmiosWebsocket.JsWebSocket , _wsClose , _wsSend ) -import Ctl.Internal.QueryM.OgmiosWebsocket.Mempool +import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , WebSocket(WebSocket) , defaultMessageListener diff --git a/test/Plutus/Time.purs b/test/Plutus/Time.purs index 58fc16903a..0072ef0b30 100644 --- a/test/Plutus/Time.purs +++ b/test/Plutus/Time.purs @@ -16,7 +16,7 @@ import Cardano.Types.EraSummaries , SafeZone(SafeZone) , SlotLength(SlotLength) ) -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosEraSummaries(OgmiosEraSummaries) , OgmiosSystemStart ) diff --git a/test/ProtocolParameters.purs b/test/ProtocolParameters.purs index bc8dc32324..7dfa8c456f 100644 --- a/test/ProtocolParameters.purs +++ b/test/ProtocolParameters.purs @@ -8,7 +8,7 @@ import Prelude import Aeson (class DecodeAeson, decodeJsonString) import Contract.Test.Mote (TestPlanM, interpretWithConfig) import Control.Monad.Error.Class (liftEither) -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosProtocolParameters(OgmiosProtocolParameters) ) import Ctl.Internal.Service.Blockfrost diff --git a/test/QueryM/AffInterface.purs b/test/QueryM/AffInterface.purs index 281f9a4f52..2a5db33993 100644 --- a/test/QueryM/AffInterface.purs +++ b/test/QueryM/AffInterface.purs @@ -8,7 +8,7 @@ import Control.Monad.Except (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) -import Ctl.Internal.QueryM.OgmiosHttp (getChainTip, submitTxOgmios) +import Ctl.Internal.QueryM.Ogmios (getChainTip, submitTxOgmios) import Data.ByteArray (hexToByteArrayUnsafe) import Data.Either (Either(Left, Right)) import Data.Maybe (fromJust, isJust) diff --git a/test/Testnet/Contract/OgmiosMempool.purs b/test/Testnet/Contract/OgmiosMempool.purs index 5a47a90c0a..33c38ae55d 100644 --- a/test/Testnet/Contract/OgmiosMempool.purs +++ b/test/Testnet/Contract/OgmiosMempool.purs @@ -5,6 +5,7 @@ module Test.Ctl.Testnet.Contract.OgmiosMempool import Prelude import Cardano.Types.BigNum as BigNum +import Cardano.Types.PlutusScript (hash) as PlutusScript import Contract.Backend.Ogmios.Mempool ( acquireMempoolSnapshot , fetchMempoolTxs @@ -12,12 +13,11 @@ import Contract.Backend.Ogmios.Mempool , mempoolSnapshotSizeAndCapacity , withMempoolSnapshot ) -import Contract.Scripts (validatorHash) import Contract.Test (ContractTest, InitialUTxOs, withKeyWallet, withWallets) import Contract.Test.Mote (TestPlanM) import Contract.Transaction (awaitTxConfirmed) import Ctl.Examples.PlutusV2.InlineDatum as InlineDatum -import Ctl.Internal.QueryM.Ogmios +import Ctl.Internal.QueryM.Ogmios.Types ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) ) import Data.Array (length) @@ -46,7 +46,7 @@ suite = group "Ogmios mempool test" do withWallets distribution \alice -> do withKeyWallet alice do validator <- InlineDatum.checkDatumIsInlineScript - let vhash = validatorHash validator + let vhash = PlutusScript.hash validator txId <- InlineDatum.payToCheckDatumIsInline vhash mpTxs <- fetchMempoolTxs =<< acquireMempoolSnapshot length mpTxs `shouldEqual` 1 @@ -65,7 +65,7 @@ suite = group "Ogmios mempool test" do withWallets distribution \alice -> do withKeyWallet alice do validator <- InlineDatum.checkDatumIsInlineScript - let vhash = validatorHash validator + let vhash = PlutusScript.hash validator txId <- InlineDatum.payToCheckDatumIsInline vhash withMempoolSnapshot (flip mempoolSnapshotHasTx txId) >>= shouldEqual true @@ -86,7 +86,7 @@ suite = group "Ogmios mempool test" do withWallets distribution \alice -> do withKeyWallet alice do validator <- InlineDatum.checkDatumIsInlineScript - let vhash = validatorHash validator + let vhash = PlutusScript.hash validator void $ InlineDatum.payToCheckDatumIsInline vhash MempoolSizeAndCapacity { numberOfTxs } <- withMempoolSnapshot (mempoolSnapshotSizeAndCapacity) diff --git a/test/Types/Interval.purs b/test/Types/Interval.purs index 27feae25c0..92c7118ebe 100644 --- a/test/Types/Interval.purs +++ b/test/Types/Interval.purs @@ -12,7 +12,7 @@ import Cardano.Types.BigNum (fromInt) as BigNum import Cardano.Types.EraSummaries (EraSummaries) import Control.Monad.Error.Class (liftEither) import Control.Monad.Except (throwError) -import Ctl.Internal.QueryM.Ogmios (OgmiosEraSummaries, OgmiosSystemStart) +import Ctl.Internal.QueryM.Ogmios.Types (OgmiosEraSummaries, OgmiosSystemStart) import Ctl.Internal.Types.Interval ( Interval , POSIXTime(POSIXTime) diff --git a/test/Types/Ipv6.purs b/test/Types/Ipv6.purs index dbf8404b47..12b77288de 100644 --- a/test/Types/Ipv6.purs +++ b/test/Types/Ipv6.purs @@ -5,7 +5,7 @@ module Test.Ctl.Types.Ipv6 import Prelude import Cardano.AsCbor (decodeCbor) -import Ctl.Internal.QueryM.Ogmios (parseIpv6String) +import Ctl.Internal.QueryM.Ogmios.Types (parseIpv6String) import Data.ByteArray (hexToByteArrayUnsafe) import Data.Newtype (wrap) import Effect.Aff (Aff) From 83b2c497053f1bda1fa3f9f6f53bcb8a3f123194 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 13:20:31 -0300 Subject: [PATCH 06/27] Clean and simplify Ogmios related code --- src/Contract/Backend/Ogmios.purs | 4 +- src/Internal/Contract/Provider.purs | 24 +- src/Internal/QueryM/CurrentEpoch.purs | 4 +- src/Internal/QueryM/EraSummaries.purs | 4 +- src/Internal/QueryM/Ogmios.purs | 1005 ++----------------------- src/Internal/QueryM/Pools.purs | 8 +- src/Internal/Types/Interval.purs | 2 +- 7 files changed, 94 insertions(+), 957 deletions(-) diff --git a/src/Contract/Backend/Ogmios.purs b/src/Contract/Backend/Ogmios.purs index 78a7747a5c..453a47bfa0 100644 --- a/src/Contract/Backend/Ogmios.purs +++ b/src/Contract/Backend/Ogmios.purs @@ -11,7 +11,7 @@ import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.TransactionHash (TransactionHash) import Contract.Monad (Contract) import Ctl.Internal.Contract.Monad (wrapQueryM) -import Ctl.Internal.QueryM.Ogmios (submitTxOgmios) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios (submitTxOgmios) as Ogmios import Ctl.Internal.QueryM.Ogmios.Types (SubmitTxR) import Ctl.Internal.QueryM.Pools (getPoolParameters) as QueryM @@ -26,4 +26,4 @@ getPoolParameters = wrapQueryM <<< QueryM.getPoolParameters -- | Error returning variant submitTxE :: TransactionHash -> CborBytes -> Contract SubmitTxR -submitTxE txhash cbor = wrapQueryM $ OgmiosHttp.submitTxOgmios txhash cbor +submitTxE txhash cbor = wrapQueryM $ Ogmios.submitTxOgmios txhash cbor diff --git a/src/Internal/Contract/Provider.purs b/src/Internal/Contract/Provider.purs index 9b511b0184..2be4fb6a2a 100644 --- a/src/Internal/Contract/Provider.purs +++ b/src/Internal/Contract/Provider.purs @@ -16,8 +16,8 @@ import Ctl.Internal.Contract.LogParams (LogParams) import Ctl.Internal.Contract.ProviderBackend (BlockfrostBackend, CtlBackend) import Ctl.Internal.Helpers (logWithLevel) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) as OgmiosHttp -import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) as OgmiosHttp +import Ctl.Internal.QueryM.CurrentEpoch (getCurrentEpoch) as Ogmios +import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) as Ogmios import Ctl.Internal.QueryM.Kupo ( getDatumByHash , getOutputAddressesByTxHash @@ -31,13 +31,13 @@ import Ctl.Internal.QueryM.Ogmios ( evaluateTxOgmios , getChainTip , submitTxOgmios - ) as OgmiosHttp + ) as Ogmios import Ctl.Internal.QueryM.Ogmios.Types (SubmitTxR(SubmitFail, SubmitTxSuccess)) import Ctl.Internal.QueryM.Pools ( getPoolIds , getPubKeyHashDelegationsAndRewards , getValidatorHashDelegationsAndRewards - ) as OgmiosHttp + ) as Ogmios import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM @@ -63,13 +63,13 @@ providerForCtlBackend runQueryM params backend = , doesTxExist: runQueryM' <<< map (map isJust) <<< Kupo.isTxConfirmed , getTxAuxiliaryData: runQueryM' <<< Kupo.getTxAuxiliaryData , utxosAt: runQueryM' <<< Kupo.utxosAt - , getChainTip: Right <$> runQueryM' OgmiosHttp.getChainTip - , getCurrentEpoch: unwrap <$> runQueryM' OgmiosHttp.getCurrentEpoch + , getChainTip: Right <$> runQueryM' Ogmios.getChainTip + , getCurrentEpoch: unwrap <$> runQueryM' Ogmios.getCurrentEpoch , submitTx: \tx -> runQueryM' do let txHash = Transaction.hash tx logDebug' $ "Pre-calculated tx hash: " <> show txHash let txCborBytes = encodeCbor tx - result <- OgmiosHttp.submitTxOgmios txHash txCborBytes + result <- Ogmios.submitTxOgmios txHash txCborBytes pure $ case result of SubmitTxSuccess th -> do if th == txHash then Right th @@ -81,15 +81,15 @@ providerForCtlBackend runQueryM params backend = , evaluateTx: \tx additionalUtxos -> runQueryM' do let txBytes = encodeCbor tx - OgmiosHttp.evaluateTxOgmios txBytes (wrap additionalUtxos) - , getEraSummaries: Right <$> runQueryM' OgmiosHttp.getEraSummaries - , getPoolIds: Right <$> runQueryM' OgmiosHttp.getPoolIds + Ogmios.evaluateTxOgmios txBytes (wrap additionalUtxos) + , getEraSummaries: Right <$> runQueryM' Ogmios.getEraSummaries + , getPoolIds: Right <$> runQueryM' Ogmios.getPoolIds , getPubKeyHashDelegationsAndRewards: \_ pubKeyHash -> Right <$> runQueryM' - (OgmiosHttp.getPubKeyHashDelegationsAndRewards pubKeyHash) + (Ogmios.getPubKeyHashDelegationsAndRewards pubKeyHash) , getValidatorHashDelegationsAndRewards: \_ validatorHash -> Right <$> runQueryM' - (OgmiosHttp.getValidatorHashDelegationsAndRewards $ wrap validatorHash) + (Ogmios.getValidatorHashDelegationsAndRewards $ wrap validatorHash) } where diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index a9695679f5..beee5ec079 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -8,7 +8,7 @@ import Prelude import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) -import Ctl.Internal.QueryM.Ogmios (currentEpoch) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios (currentEpoch) as Ogmios import Ctl.Internal.QueryM.Ogmios.Types (CurrentEpoch) import Data.Either (Either(Right, Left)) import Effect.Exception (error) @@ -17,7 +17,7 @@ import Effect.Exception (error) -- | "currentEpoch" query getCurrentEpoch :: QueryM CurrentEpoch getCurrentEpoch = do - resp <- OgmiosHttp.currentEpoch + resp <- Ogmios.currentEpoch case resp of Left err -> throwError $ error $ pprintOgmiosDecodeError err Right val -> pure val diff --git a/src/Internal/QueryM/EraSummaries.purs b/src/Internal/QueryM/EraSummaries.purs index a07c05d622..77e1c84c99 100644 --- a/src/Internal/QueryM/EraSummaries.purs +++ b/src/Internal/QueryM/EraSummaries.purs @@ -9,7 +9,7 @@ import Cardano.Types.EraSummaries (EraSummaries) import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) -import Ctl.Internal.QueryM.Ogmios (eraSummaries) as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios (eraSummaries) as Ogmios import Data.Either (Either(Right, Left)) import Data.Newtype (unwrap) import Effect.Exception (error) @@ -18,7 +18,7 @@ import Effect.Exception (error) -- | https://ogmios.dev/api/ under "eraSummaries" query getEraSummaries :: QueryM EraSummaries getEraSummaries = do - resp <- OgmiosHttp.eraSummaries + resp <- Ogmios.eraSummaries case resp of Left err -> throwError $ error $ pprintOgmiosDecodeError err Right val -> pure $ unwrap $ val diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 99cce01ca3..95516ea408 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -1,11 +1,9 @@ module Ctl.Internal.QueryM.Ogmios ( getSystemStartTime - , aesonObject , getChainTip , currentEpoch , submitTxOgmios , poolParameters - , StakePoolsQueryArgument(StakePoolsQueryArgument) , delegationsAndRewards , eraSummaries , getProtocolParameters @@ -14,23 +12,7 @@ module Ctl.Internal.QueryM.Ogmios import Prelude -import Aeson - ( class DecodeAeson - , class EncodeAeson - , Aeson - , JsonDecodeError(TypeMismatch, MissingValue, AtKey) - , caseAesonArray - , caseAesonObject - , caseAesonString - , decodeAeson - , encodeAeson - , fromArray - , getField - , isNull - , parseJsonStringToAeson - , stringifyAeson - , (.:?) - ) +import Aeson (class EncodeAeson, Aeson, parseJsonStringToAeson, stringifyAeson) import Aeson as Aeson import Affjax (Error, Response, defaultRequest) as Affjax import Affjax.RequestBody as Affjax.RequestBody @@ -38,160 +20,67 @@ import Affjax.RequestHeader as Affjax.RequestHeader import Affjax.ResponseFormat (string) as Affjax.ResponseFormat import Affjax.StatusCode (StatusCode(StatusCode)) import Affjax.StatusCode as Affjax.StatusCode -import Cardano.AsCbor (encodeCbor) import Cardano.Provider.Error ( ClientError(ClientHttpError, ClientHttpResponseError) , ServiceError(ServiceOtherError) ) import Cardano.Provider.TxEvaluation as Provider -import Cardano.Serialization.Lib (fromBytes) -import Cardano.Types - ( Bech32String - , BigNum(BigNum) - , Language(PlutusV3, PlutusV2, PlutusV1) - , RedeemerTag - ) -import Cardano.Types.AssetName (unAssetName) -import Cardano.Types.BigNum (BigNum) -import Cardano.Types.BigNum (fromBigInt) as BigNum import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.Chain as Chain -import Cardano.Types.Coin (Coin(Coin)) -import Cardano.Types.CostModel (CostModel(CostModel)) -import Cardano.Types.EraSummaries - ( EraSummaries(EraSummaries) - , EraSummary(EraSummary) - , EraSummaryParameters(EraSummaryParameters) - , EraSummaryTime(EraSummaryTime) - ) -import Cardano.Types.ExUnitPrices (ExUnitPrices(ExUnitPrices)) -import Cardano.Types.ExUnits (ExUnits(ExUnits)) -import Cardano.Types.Int as Cardano -import Cardano.Types.NativeScript - ( NativeScript - ( ScriptPubkey - , ScriptAll - , ScriptAny - , ScriptNOfK - , TimelockStart - , TimelockExpiry - ) - ) -import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) -import Cardano.Types.PoolPubKeyHash (PoolPubKeyHash) -import Cardano.Types.RedeemerTag - ( RedeemerTag(Spend, Mint, Cert, Reward, Vote, Propose) - ) as RedeemerTag -import Cardano.Types.ScriptHash (ScriptHash) -import Cardano.Types.ScriptRef (ScriptRef(NativeScriptRef, PlutusScriptRef)) -import Cardano.Types.Slot (Slot(Slot)) import Cardano.Types.TransactionHash (TransactionHash) -import Cardano.Types.UnitInterval (UnitInterval(UnitInterval)) -import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) import Contract.Log (logTrace') import Control.Monad.Error.Class (class MonadThrow, throwError) import Control.Monad.Reader.Class (asks) import Ctl.Internal.Affjax (request) as Affjax -import Ctl.Internal.Helpers (encodeMap, showWithParens) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 ( class DecodeOgmios - , OgmiosDecodeError(ClientErrorResponse, ResultDecodingError) - , OgmiosError - , decodeErrorOrResult + , OgmiosDecodeError(ResultDecodingError, ClientErrorResponse) , decodeOgmios - , decodeResult , pprintOgmiosDecodeError ) import Ctl.Internal.QueryM.Ogmios.Types ( AdditionalUtxoSet + , ChainTipQR(CtChainPoint, CtChainOrigin) , CurrentEpoch - , DelegationsAndRewardsR(DelegationsAndRewardsR) + , DelegationsAndRewardsR , OgmiosEraSummaries , OgmiosProtocolParameters , OgmiosSystemStart , OgmiosTxEvaluationR , PoolParametersR + , StakePoolsQueryArgument , SubmitTxR - ) as Ogmios -import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) -import Ctl.Internal.Types.ProtocolParameters - ( ProtocolParameters(ProtocolParameters) - ) -import Ctl.Internal.Types.Rational (Rational, (%)) -import Ctl.Internal.Types.Rational as Rational -import Ctl.Internal.Types.SystemStart - ( SystemStart - , sysStartFromOgmiosTimestamp - , sysStartToOgmiosTimestamp ) -import Data.Array (catMaybes) -import Data.Array (fromFoldable) as Array +import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) import Data.Bifunctor (lmap) -import Data.ByteArray (byteArrayToHex, hexToByteArray) -import Data.Either (Either(Left, Right), either, note) -import Data.Foldable (foldl) -import Data.Generic.Rep (class Generic) +import Data.ByteArray (byteArrayToHex) +import Data.Either (Either(Right, Left)) import Data.HTTP.Method (Method(POST)) import Data.Lens (_Right, to, (^?)) -import Data.List (List) -import Data.List as List -import Data.Map (Map) -import Data.Map as Map -import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe) -import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Show.Generic (genericShow) -import Data.String (Pattern(Pattern)) -import Data.String.Common (split) as String +import Data.Maybe (Maybe(Just)) +import Data.Newtype (unwrap, wrap) import Data.Time.Duration (Milliseconds(Milliseconds)) -import Data.Traversable (for, traverse) -import Data.Tuple (Tuple(Tuple)) import Data.Tuple.Nested (type (/\), (/\)) -import Data.UInt (UInt) import Effect.Aff (Aff, delay) import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Exception (Error, error) -import Foreign.Object (Object) -import Foreign.Object as Object -import JS.BigInt as BigInt -import Untagged.TypeCheck (class HasRuntimeType) -import Untagged.Union (type (|+|), toEither1) -eraSummaries :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosEraSummaries) -eraSummaries = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "eraSummaries" - , method: "queryLedgerState/eraSummaries" - } - ) +eraSummaries :: QueryM (Either OgmiosDecodeError OgmiosEraSummaries) +eraSummaries = ogmiosQueryNoParams "queryLedgerState/eraSummaries" -getSystemStartTime :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosSystemStart) -getSystemStartTime = do - let - body = Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "getSystemStartTime" - , method: "queryNetwork/startTime" - } - handleAffjaxOgmiosResponse <$> ogmiosPostRequest body +getSystemStartTime :: QueryM (Either OgmiosDecodeError OgmiosSystemStart) +getSystemStartTime = ogmiosQueryNoParams "queryNetwork/startTime" getProtocolParameters - :: QueryM (Either OgmiosDecodeError Ogmios.OgmiosProtocolParameters) -getProtocolParameters = do - let - body = Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "getProtocolParameters" - , method: "queryLedgerState/protocolParameters" - } - handleAffjaxOgmiosResponse <$> ogmiosPostRequest body + :: QueryM (Either OgmiosDecodeError OgmiosProtocolParameters) +getProtocolParameters = ogmiosQueryNoParams + "queryLedgerState/protocolParameters" getChainTip :: QueryM Chain.Tip getChainTip = do - ogmiosChainTipToTip <$> ogmiosErrorHandler chainTip + ogmiosChainTipToTip <$> ogmiosErrorHandler + (ogmiosQueryNoParams "queryNetwork/tip") where ogmiosChainTipToTip :: ChainTipQR -> Chain.Tip ogmiosChainTipToTip = case _ of @@ -199,834 +88,82 @@ getChainTip = do CtChainPoint { slot, id } -> Chain.Tip $ wrap { slot, blockHeaderHash: wrap $ unwrap id } - chainTip :: QueryM (Either OgmiosDecodeError ChainTipQR) - chainTip = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "getChainTip" - , method: "queryNetwork/tip" - } - ) - -currentEpoch :: QueryM (Either OgmiosDecodeError Ogmios.CurrentEpoch) -currentEpoch = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "currentEpoch" - , method: "queryLedgerState/epoch" - } - ) +currentEpoch :: QueryM (Either OgmiosDecodeError CurrentEpoch) +currentEpoch = ogmiosQueryNoParams "queryLedgerState/epoch" -submitTxOgmios :: TransactionHash -> CborBytes -> QueryM Ogmios.SubmitTxR +submitTxOgmios :: TransactionHash -> CborBytes -> QueryM SubmitTxR submitTxOgmios txHash tx = ogmiosErrorHandlerWithArg submitTx (txHash /\ tx) where - submitTx - :: TransactionHash /\ CborBytes - -> QueryM (Either OgmiosDecodeError Ogmios.SubmitTxR) - submitTx (_ /\ cbor) = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "submitTxOgmios" - , method: "submitTransaction" - , params: - { transaction: - { cbor: byteArrayToHex (unwrap cbor) - } - } - } - ) + submitTx (_ /\ cbor) = ogmiosQueryParams "submitTransaction" + { transaction: + { cbor: byteArrayToHex (unwrap cbor) + } + } poolParameters :: StakePoolsQueryArgument - -> QueryM (Either OgmiosDecodeError Ogmios.PoolParametersR) -poolParameters stakePools = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "poolParameters" - , method: "queryLedgerState/stakePools" - , params: stakePools - } - ) + -> QueryM (Either OgmiosDecodeError PoolParametersR) +poolParameters stakePools = ogmiosQueryParams "queryLedgerState/stakePools" + stakePools delegationsAndRewards :: Array String -- ^ A list of reward account bech32 strings - -> QueryM (Either OgmiosDecodeError Ogmios.DelegationsAndRewardsR) -delegationsAndRewards rewardAccounts = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "delegationsAndRewards" - , method: "queryLedgerState/rewardAccountSummaries" - , params: - { query: - { delegationsAndRewards: rewardAccounts } - } - } - ) + -> QueryM (Either OgmiosDecodeError DelegationsAndRewardsR) +delegationsAndRewards rewardAccounts = ogmiosQueryParams + "queryLedgerState/rewardAccountSummaries" + { query: + { delegationsAndRewards: rewardAccounts } + } evaluateTxOgmios - :: CborBytes -> Ogmios.AdditionalUtxoSet -> QueryM Provider.TxEvaluationR + :: CborBytes -> AdditionalUtxoSet -> QueryM Provider.TxEvaluationR evaluateTxOgmios cbor additionalUtxos = unwrap <$> ogmiosErrorHandlerWithArg evaluateTx (cbor /\ additionalUtxos) where evaluateTx - :: CborBytes /\ Ogmios.AdditionalUtxoSet - -> QueryM (Either OgmiosDecodeError Ogmios.OgmiosTxEvaluationR) - evaluateTx (cbor_ /\ utxoqr) = do - handleAffjaxOgmiosResponse <$> - ( ogmiosPostRequest - $ Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "evaluateTxOgmios" - , method: "evaluateTransaction" - , params: - { transaction: { cbor: byteArrayToHex $ unwrap cbor_ } - , additionalUtxo: utxoqr - } - } - ) - -instance DecodeOgmios TxEvaluationR where - decodeOgmios = decodeErrorOrResult - { parseError: map (wrap <<< Left) <<< decodeAeson } - { parseResult: map (wrap <<< Right) <<< decodeAeson } + :: CborBytes /\ AdditionalUtxoSet + -> QueryM (Either OgmiosDecodeError OgmiosTxEvaluationR) + evaluateTx (cbor_ /\ utxoqr) = ogmiosQueryParams "evaluateTransaction" + { transaction: { cbor: byteArrayToHex $ unwrap cbor_ } + , additionalUtxo: utxoqr + } --- Response parsing -------------------------------------------------------------------------------- - -type OgmiosAddress = Bech32String - --------------------------------------------------------------------------------- --- Local Tx Monitor Query Response & Parsing +-- Helpers -------------------------------------------------------------------------------- -newtype HasTxR = HasTxR Boolean - -derive instance Newtype HasTxR _ - -instance DecodeOgmios HasTxR where - decodeOgmios = decodeResult (map HasTxR <<< decodeAeson) - ----------------- TX SUBMISSION QUERY RESPONSE & PARSING - -data SubmitTxR - = SubmitTxSuccess TransactionHash - | SubmitFail OgmiosError - -derive instance Generic SubmitTxR _ - -instance Show SubmitTxR where - show = genericShow - -instance DecodeOgmios SubmitTxR where - decodeOgmios = decodeErrorOrResult - { parseError: decodeError } - { parseResult: map SubmitTxSuccess <<< decodeTxHash } - - where - - decodeError aeson = map SubmitFail do - -- With Ogmios 5.6 we failed with error on deserialization error, so we do now as well - err :: OgmiosError <- decodeAeson aeson - let code = (unwrap err).code - -- as of 7.11.23 it's in {3005} u [3100, 3159] range - if (3000 <= code && code <= 3999) then - pure err - else - Left $ TypeMismatch - "Expected error code in a range [3000, 3999]" - - decodeTxHash :: Aeson -> Either JsonDecodeError TransactionHash - decodeTxHash = aesonObject \o -> do - txHashHex <- getField o "transaction" >>= flip getField "id" - note (TypeMismatch "Expected hexstring of TransactionHash") $ - hexToByteArray txHashHex >>= fromBytes >>> map wrap - ----------------- SYSTEM START QUERY RESPONSE & PARSING -newtype OgmiosSystemStart = OgmiosSystemStart SystemStart - -derive instance Generic OgmiosSystemStart _ -derive instance Newtype OgmiosSystemStart _ -derive newtype instance Eq OgmiosSystemStart - -instance Show OgmiosSystemStart where - show = genericShow - -instance DecodeAeson OgmiosSystemStart where - decodeAeson = - caseAesonString (Left (TypeMismatch "Timestamp string")) - (map wrap <<< lmap TypeMismatch <<< sysStartFromOgmiosTimestamp) - -instance EncodeAeson OgmiosSystemStart where - encodeAeson = encodeAeson <<< sysStartToOgmiosTimestamp <<< unwrap - -instance DecodeOgmios OgmiosSystemStart where - decodeOgmios = decodeResult decodeAeson - ----------------- CURRENT EPOCH QUERY RESPONSE & PARSING -newtype CurrentEpoch = CurrentEpoch BigNum - -derive instance Generic CurrentEpoch _ -derive instance Newtype CurrentEpoch _ -derive newtype instance DecodeAeson CurrentEpoch -derive newtype instance EncodeAeson CurrentEpoch -derive newtype instance Eq CurrentEpoch -derive newtype instance Ord CurrentEpoch - -instance Show CurrentEpoch where - show (CurrentEpoch ce) = showWithParens "CurrentEpoch" ce - -instance DecodeOgmios CurrentEpoch where - decodeOgmios = decodeResult decodeAeson - ----------------- ERA SUMMARY QUERY RESPONSE & PARSING - -newtype OgmiosEraSummaries = OgmiosEraSummaries EraSummaries - -derive instance Generic OgmiosEraSummaries _ -derive instance Newtype OgmiosEraSummaries _ -derive newtype instance Eq OgmiosEraSummaries - -instance Show OgmiosEraSummaries where - show = genericShow - -instance DecodeAeson OgmiosEraSummaries where - -- There is some differences between ogmios 6.0 spec and actual results - -- in "start" "end" fields and "slotLength". - decodeAeson = aesonArray (map (wrap <<< wrap) <<< traverse decodeEraSummary) - where - decodeEraSummaryTime :: Aeson -> Either JsonDecodeError EraSummaryTime - decodeEraSummaryTime = aesonObject \obj -> do - time <- flip getField "seconds" =<< getField obj "time" - slot <- getField obj "slot" - epoch <- getField obj "epoch" - pure $ wrap { time, slot, epoch } - - decodeEraSummary :: Aeson -> Either JsonDecodeError EraSummary - decodeEraSummary = aesonObject \o -> do - start <- decodeEraSummaryTime =<< getField o "start" - -- The field "end" is required by Ogmios API, but it can optionally return - -- Null, so we want to fail if the field is absent but make Null value - -- acceptable in presence of the field (hence why "end" is wrapped in - -- `Maybe`). - end' <- getField o "end" - end <- - if isNull end' then pure Nothing else Just <$> decodeEraSummaryTime end' - parameters <- decodeEraSummaryParameters =<< getField o "parameters" - pure $ wrap { start, end, parameters } - - decodeEraSummaryParameters - :: Object Aeson -> Either JsonDecodeError EraSummaryParameters - decodeEraSummaryParameters o = do - epochLength <- getField o "epochLength" - slotLength <- flip getField "milliseconds" =<< getField o "slotLength" - safeZone <- fromMaybe zero <$> getField o "safeZone" - pure $ wrap { epochLength, slotLength, safeZone } - -instance EncodeAeson OgmiosEraSummaries where - encodeAeson (OgmiosEraSummaries (EraSummaries es)) = - fromArray $ map encodeEraSummary es - where - encodeEraSummaryTime :: EraSummaryTime -> Aeson - encodeEraSummaryTime (EraSummaryTime { time, slot, epoch }) = - encodeAeson { "time": { "seconds": time }, "slot": slot, "epoch": epoch } - - encodeEraSummary :: EraSummary -> Aeson - encodeEraSummary (EraSummary { start, end, parameters }) = - encodeAeson - { "start": encodeEraSummaryTime start - , "end": encodeEraSummaryTime <$> end - , "parameters": encodeEraSummaryParameters parameters - } - - encodeEraSummaryParameters :: EraSummaryParameters -> Aeson - encodeEraSummaryParameters (EraSummaryParameters params) = - encodeAeson - { "epochLength": params.epochLength - , "slotLength": { "milliseconds": params.slotLength } - , "safeZone": params.safeZone - } - -instance DecodeOgmios OgmiosEraSummaries where - decodeOgmios = decodeResult decodeAeson - ----------------- DELEGATIONS & REWARDS QUERY RESPONSE & PARSING - -newtype DelegationsAndRewardsR = DelegationsAndRewardsR - ( Map String - { rewards :: Maybe Coin - , delegate :: Maybe PoolPubKeyHash - } - ) - -derive instance Generic DelegationsAndRewardsR _ -derive instance Newtype DelegationsAndRewardsR _ - -instance DecodeAeson DelegationsAndRewardsR where - decodeAeson aeson = do - obj :: Object (Object Aeson) <- decodeAeson aeson - kvs <- for (Object.toUnfoldable obj :: Array _) \(Tuple k objParams) -> do - rewards <- map Coin <$> objParams .:? "rewards" - delegate <- objParams .:? "delegate" - pure $ k /\ { rewards, delegate } - pure $ DelegationsAndRewardsR $ Map.fromFoldable kvs - -instance DecodeOgmios DelegationsAndRewardsR where - decodeOgmios = decodeResult decodeAeson - ----------------- POOL PARAMETERS REQUEST & PARSING - --- Nothing queries all pools, otherwise query selected pools. -newtype StakePoolsQueryArgument = StakePoolsQueryArgument - (Maybe (Array PoolPubKeyHash)) - -derive instance Newtype StakePoolsQueryArgument _ - -instance EncodeAeson StakePoolsQueryArgument where - encodeAeson a = do - maybe - (encodeAeson {}) - ( \poolPkhs -> encodeAeson - { stakePools: map (\pool -> { id: pool }) poolPkhs } - ) - (unwrap a) - ----------------- TX EVALUATION QUERY RESPONSE & PARSING - -type RedeemerPointer = { redeemerTag :: RedeemerTag, redeemerIndex :: UInt } - -type ExecutionUnits = { memory :: BigNum, steps :: BigNum } - -type OgmiosRedeemerPtr = { index :: UInt, purpose :: String } - -newtype TxEvaluationR = TxEvaluationR - (Either TxEvaluationFailure TxEvaluationResult) - -derive instance Newtype TxEvaluationR _ -derive instance Generic TxEvaluationR _ - -instance Show TxEvaluationR where - show = genericShow - -newtype TxEvaluationResult = TxEvaluationResult - (Map RedeemerPointer ExecutionUnits) - -derive instance Newtype TxEvaluationResult _ -derive instance Generic TxEvaluationResult _ - -instance Show TxEvaluationResult where - show = genericShow - -instance DecodeAeson TxEvaluationResult where - decodeAeson = aesonArray $ \array -> do - TxEvaluationResult <<< Map.fromFoldable <$> - traverse decodeRdmrPtrExUnitsItem array - - where - decodeRdmrPtrExUnitsItem - :: Aeson -> Either JsonDecodeError (RedeemerPointer /\ ExecutionUnits) - decodeRdmrPtrExUnitsItem elem = do - res - :: { validator :: OgmiosRedeemerPtr - , budget :: { memory :: BigNum, cpu :: BigNum } - } <- decodeAeson elem - redeemerPtr <- decodeRedeemerPointer res.validator - pure $ redeemerPtr /\ { memory: res.budget.memory, steps: res.budget.cpu } - -redeemerTypeMismatch :: JsonDecodeError -redeemerTypeMismatch = TypeMismatch - "Expected redeemer to be one of: \ - \(spend|mint|publish|withdraw|vote|propose)" - -decodeRedeemerPointer - :: { index :: UInt, purpose :: String } - -> Either JsonDecodeError RedeemerPointer -decodeRedeemerPointer { index: redeemerIndex, purpose } = - note redeemerTypeMismatch $ { redeemerTag: _, redeemerIndex } <$> - redeemerTagFromString purpose - -redeemerTagFromString :: String -> Maybe RedeemerTag -redeemerTagFromString = case _ of - "spend" -> Just RedeemerTag.Spend - "mint" -> Just RedeemerTag.Mint - "publish" -> Just RedeemerTag.Cert - "withdraw" -> Just RedeemerTag.Reward - "vote" -> Just RedeemerTag.Vote - "propose" -> Just RedeemerTag.Propose - _ -> Nothing - -type OgmiosDatum = String -type OgmiosScript = String -type OgmiosTxId = String -type OgmiosTxIn = { txId :: OgmiosTxId, index :: Prim.Int } - --- | Reason a script failed. --- --- The type definition is a least common denominator between Ogmios v6 format used by ogmios backend --- and ogmios v5.6 format used by blockfrost backend -data ScriptFailure - = ExtraRedeemers (Array RedeemerPointer) - | MissingRequiredDatums - { missing :: (Array OgmiosDatum) - , provided :: Maybe (Array OgmiosDatum) - } - | MissingRequiredScripts - { missing :: Array RedeemerPointer - , resolved :: Maybe (Map RedeemerPointer ScriptHash) - } - | ValidatorFailed { error :: String, traces :: Array String } - | UnknownInputReferencedByRedeemer (Array OgmiosTxIn) - | NonScriptInputReferencedByRedeemer OgmiosTxIn - | NoCostModelForLanguage (Array String) - | InternalLedgerTypeConversionError String - | IllFormedExecutionBudget (Maybe ExecutionUnits) - -derive instance Generic ScriptFailure _ - -instance Show ScriptFailure where - show = genericShow - --- The following cases are fine to fall through into unparsed error: --- IncompatibleEra --- NotEnoughSynced --- CannotCreateEvaluationContext -data TxEvaluationFailure - = UnparsedError String - | AdditionalUtxoOverlap (Array OgmiosTxOutRef) - | ScriptFailures (Map RedeemerPointer (Array ScriptFailure)) - -derive instance Generic TxEvaluationFailure _ - -instance Show TxEvaluationFailure where - show = genericShow - -instance DecodeAeson ScriptFailure where - decodeAeson aeson = do - err :: OgmiosError <- decodeAeson aeson - let error = unwrap err - errorData <- maybe (Left (AtKey "data" MissingValue)) pure error.data - case error.code of - 3011 -> do - res :: { missingScripts :: Array OgmiosRedeemerPtr } <- decodeAeson - errorData - missing <- traverse decodeRedeemerPointer res.missingScripts - pure $ MissingRequiredScripts { missing: missing, resolved: Nothing } - 3012 -> do - res :: { validationError :: String, traces :: Array String } <- - decodeAeson errorData - pure $ ValidatorFailed - { error: res.validationError, traces: res.traces } - 3013 -> do - res - :: { unsuitableOutputReference :: - { transaction :: { id :: String }, index :: Prim.Int } - } <- decodeAeson errorData - pure $ NonScriptInputReferencedByRedeemer - { index: res.unsuitableOutputReference.index - , txId: res.unsuitableOutputReference.transaction.id - } - 3110 -> do - res :: { extraneousRedeemers :: Array OgmiosRedeemerPtr } <- decodeAeson - errorData - ExtraRedeemers <$> traverse decodeRedeemerPointer - res.extraneousRedeemers - 3111 -> do - res :: { missingDatums :: Array String } <- decodeAeson errorData - pure $ MissingRequiredDatums - { missing: res.missingDatums, provided: Nothing } - 3117 -> do - res - :: { unknownOutputReferences :: - Array { transaction :: { id :: String }, index :: Prim.Int } - } <- decodeAeson errorData - pure $ UnknownInputReferencedByRedeemer $ - map (\x -> { index: x.index, txId: x.transaction.id }) - res.unknownOutputReferences - 3115 -> do - res :: { missingCostModels :: Array String } <- decodeAeson errorData - pure $ NoCostModelForLanguage res.missingCostModels - -- this would actually fail at decoding error.data but it's good - 3999 -> pure $ InternalLedgerTypeConversionError error.message - _ -> Left $ TypeMismatch $ "Unknown ogmios error code: " <> show - error.code - -instance DecodeAeson TxEvaluationFailure where - decodeAeson aeson = do - error :: OgmiosError <- decodeAeson aeson - let code = (unwrap error).code - errorData <- maybe (Left (AtKey "data" MissingValue)) pure - (unwrap error).data - case code of - -- ScriptExecutionFailure - 3010 -> flip aesonArray errorData $ - ( \array -> - ( ScriptFailures <<< map Array.fromFoldable <<< collectIntoMap <$> - traverse parseElem array - ) - ) - -- Overlapping AdditionalUtxo - 3002 -> do - res - :: { overlappingOutputReferences :: - Array { transaction :: { id :: String }, index :: UInt } - } <- decodeAeson errorData - pure $ AdditionalUtxoOverlap $ map - (\elem -> { txId: elem.transaction.id, index: elem.index }) - res.overlappingOutputReferences - -- All other errors - _ -> pure $ UnparsedError $ stringifyAeson aeson - - where - parseElem elem = do - res :: { validator :: OgmiosRedeemerPtr, error :: ScriptFailure } <- - decodeAeson elem - (_ /\ res.error) <$> decodeRedeemerPointer res.validator - - collectIntoMap :: forall k v. Ord k => Array (k /\ v) -> Map k (List v) - collectIntoMap = foldl - ( \m (k /\ v) -> Map.alter - (maybe (Just $ List.singleton v) (Just <<< List.Cons v)) - k - m - ) - Map.empty - ----------------- PROTOCOL PARAMETERS QUERY RESPONSE & PARSING - --- | A version of `Rational` with Aeson instance that decodes from `x/y` --- | representation, instead of `{ numerator, denominator }` -newtype PParamRational = PParamRational Rational - -derive instance Newtype PParamRational _ -derive instance Generic PParamRational _ - -instance Show PParamRational where - show = genericShow - -instance DecodeAeson PParamRational where - decodeAeson = - caseAesonString (Left err) - \string -> do - case String.split (Pattern "/") string of - [ numeratorStr, denominatorStr ] -> note err do - numerator <- BigInt.fromString numeratorStr - denominator <- BigInt.fromString denominatorStr - PParamRational <$> numerator % denominator - _ -> Left err - where - err :: JsonDecodeError - err = TypeMismatch "PParamRaional" - -rationalToSubcoin :: PParamRational -> Maybe UnitInterval -rationalToSubcoin (PParamRational rat) = do - numerator <- BigNum.fromBigInt $ Rational.numerator rat - denominator <- BigNum.fromBigInt $ Rational.denominator rat - pure $ UnitInterval { numerator, denominator } - -type OgmiosAdaLovelace = { "ada" :: { "lovelace" :: BigNum } } -type OgmiosBytes = { "bytes" :: UInt } - --- | A type that corresponds to Ogmios response. -type ProtocolParametersRaw = - { "minFeeCoefficient" :: UInt - , "minFeeConstant" :: OgmiosAdaLovelace - , "minUtxoDepositCoefficient" :: BigNum - , "maxBlockBodySize" :: OgmiosBytes - , "maxBlockHeaderSize" :: OgmiosBytes - , "maxTransactionSize" :: OgmiosBytes - , "maxValueSize" :: OgmiosBytes - , "stakeCredentialDeposit" :: OgmiosAdaLovelace - , "stakePoolDeposit" :: OgmiosAdaLovelace - , "stakePoolRetirementEpochBound" :: UInt - , "desiredNumberOfStakePools" :: UInt - , "stakePoolPledgeInfluence" :: PParamRational - , "monetaryExpansion" :: PParamRational - , "treasuryExpansion" :: PParamRational - , "version" :: - { "major" :: UInt - , "minor" :: UInt - } - , "minStakePoolCost" :: OgmiosAdaLovelace - , "plutusCostModels" :: - { "plutus:v1" :: Array Cardano.Int - , "plutus:v2" :: Maybe (Array Cardano.Int) - , "plutus:v3" :: Maybe (Array Cardano.Int) - } - , "scriptExecutionPrices" :: - { "memory" :: PParamRational - , "cpu" :: PParamRational - } - , "maxExecutionUnitsPerTransaction" :: - { "memory" :: BigNum - , "cpu" :: BigNum - } - , "maxExecutionUnitsPerBlock" :: - { "memory" :: BigNum - , "cpu" :: BigNum - } - , "collateralPercentage" :: UInt - , "maxCollateralInputs" :: UInt - , "governanceActionDeposit" :: Maybe OgmiosAdaLovelace - , "delegateRepresentativeDeposit" :: Maybe OgmiosAdaLovelace - , "minFeeReferenceScripts" :: - { range :: UInt - , base :: Number - , multiplier :: Number - } - } - -newtype OgmiosProtocolParameters = OgmiosProtocolParameters ProtocolParameters - -derive instance Newtype OgmiosProtocolParameters _ -derive instance Generic OgmiosProtocolParameters _ -derive instance Eq OgmiosProtocolParameters - -instance Show OgmiosProtocolParameters where - show = genericShow - -instance DecodeAeson OgmiosProtocolParameters where - decodeAeson aeson = do - ps :: ProtocolParametersRaw <- decodeAeson aeson - prices <- decodePrices ps - minFeeReferenceScriptsBase <- - note (TypeMismatch "minFeeReferenceScripts.multiplier: expected a number") - $ Rational.fromNumber ps.minFeeReferenceScripts.base - pure $ OgmiosProtocolParameters $ ProtocolParameters - { protocolVersion: ps.version.major /\ ps.version.minor - -- The following two parameters were removed from Babbage - , decentralization: zero - , maxBlockHeaderSize: ps.maxBlockHeaderSize.bytes - , maxBlockBodySize: ps.maxBlockBodySize.bytes - , maxTxSize: ps.maxTransactionSize.bytes - , txFeeFixed: wrap ps.minFeeConstant.ada.lovelace - , txFeePerByte: ps.minFeeCoefficient - , stakeAddressDeposit: wrap ps.stakeCredentialDeposit.ada.lovelace - , stakePoolDeposit: wrap ps.stakePoolDeposit.ada.lovelace - , minPoolCost: wrap ps.minStakePoolCost.ada.lovelace - , poolRetireMaxEpoch: wrap ps.stakePoolRetirementEpochBound - , stakePoolTargetNum: ps.desiredNumberOfStakePools - , poolPledgeInfluence: unwrap ps.stakePoolPledgeInfluence - , monetaryExpansion: unwrap ps.monetaryExpansion - , treasuryCut: unwrap ps.treasuryExpansion -- Rational - , coinsPerUtxoByte: wrap ps.minUtxoDepositCoefficient - , costModels: Map.fromFoldable $ catMaybes - [ pure - ( PlutusV1 /\ CostModel - ps.plutusCostModels."plutus:v1" - ) - , Tuple PlutusV2 <<< CostModel <$> - ps.plutusCostModels."plutus:v2" - , Tuple PlutusV3 <<< CostModel <$> - ps.plutusCostModels."plutus:v3" - ] - , prices: prices - , maxTxExUnits: decodeExUnits ps.maxExecutionUnitsPerTransaction - , maxBlockExUnits: decodeExUnits ps.maxExecutionUnitsPerBlock - , maxValueSize: ps.maxValueSize.bytes - , collateralPercent: ps.collateralPercentage - , maxCollateralInputs: ps.maxCollateralInputs - , govActionDeposit: - -- NOTE: Conway fields should be optional to enable integration tests. - -- Reason: cardano-testnet runs in the Babbage era. - maybe mempty (wrap <<< _.ada.lovelace) ps.governanceActionDeposit - , drepDeposit: - maybe mempty (wrap <<< _.ada.lovelace) - ps.delegateRepresentativeDeposit - , refScriptCoinsPerByte: minFeeReferenceScriptsBase +ogmiosQueryNoParams + :: forall a + . DecodeOgmios a + => String + -> QueryM (Either OgmiosDecodeError a) +ogmiosQueryNoParams method = do + let + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "http-" <> method + , method } - where - decodeExUnits - :: { memory :: BigNum, cpu :: BigNum } -> ExUnits - decodeExUnits { memory, cpu } = ExUnits { mem: memory, steps: cpu } - - decodePrices - :: ProtocolParametersRaw -> Either JsonDecodeError ExUnitPrices - decodePrices ps = note (TypeMismatch "ExUnitPrices") $ ExUnitPrices <$> do - memPrice <- rationalToSubcoin ps.scriptExecutionPrices.memory - stepPrice <- rationalToSubcoin ps.scriptExecutionPrices.cpu - pure { memPrice, stepPrice } -- ExUnits - -instance DecodeOgmios OgmiosProtocolParameters where - decodeOgmios = decodeResult decodeAeson - ----------------- CHAIN TIP QUERY RESPONSE & PARSING - -data ChainTipQR - = CtChainOrigin ChainOrigin - | CtChainPoint ChainPoint - -derive instance Generic ChainTipQR _ - -instance Show ChainTipQR where - show = genericShow - -instance DecodeAeson ChainTipQR where - decodeAeson j = do - r :: (ChainOrigin |+| ChainPoint) <- decodeAeson j - pure $ either CtChainOrigin CtChainPoint $ toEither1 r - -instance DecodeOgmios ChainTipQR where - decodeOgmios = decodeResult decodeAeson - --- | A Blake2b 32-byte digest of an era-independent block header, serialized as --- CBOR in base16 -newtype OgmiosBlockHeaderHash = OgmiosBlockHeaderHash String - -derive instance Eq OgmiosBlockHeaderHash -derive newtype instance DecodeAeson OgmiosBlockHeaderHash -derive instance Generic OgmiosBlockHeaderHash _ -derive instance Newtype OgmiosBlockHeaderHash _ - -instance Show OgmiosBlockHeaderHash where - show = genericShow - --- | The origin of the blockchain. It doesn't point to any existing slots, but --- is preceding any existing other point. -newtype ChainOrigin = ChainOrigin String - -derive instance Eq ChainOrigin -derive newtype instance DecodeAeson ChainOrigin -derive newtype instance HasRuntimeType ChainOrigin -derive instance Generic ChainOrigin _ - -instance Show ChainOrigin where - show = genericShow - --- | A point on the chain, identified by a slot and a block header hash -type ChainPoint = - { slot :: Slot -- See https://github.com/Plutonomicon/cardano-transaction-lib/issues/632 - -- for details on why we lose a negligible amount of precision. - , id :: OgmiosBlockHeaderHash - } - ----------------- ADDITIONAL UTXO MAP REQUEST - -newtype AdditionalUtxoSet = AdditionalUtxoSet OgmiosUtxoMap - -derive instance Newtype AdditionalUtxoSet _ - -derive newtype instance Show AdditionalUtxoSet - --- Ogmios tx input -type OgmiosTxOutRef = - { txId :: String - , index :: UInt - } - -type OgmiosTxOut = - { address :: OgmiosAddress - , value :: Value - , datumHash :: Maybe String - , datum :: Maybe String - , script :: Maybe ScriptRef - } - -type OgmiosUtxoMap = Map OgmiosTxOutRef OgmiosTxOut - -instance EncodeAeson AdditionalUtxoSet where - encodeAeson (AdditionalUtxoSet m) = - encodeAeson $ encode <$> utxos - - where - utxos :: Array (OgmiosTxOutRef /\ OgmiosTxOut) - utxos = Map.toUnfoldable m + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body - encode :: (OgmiosTxOutRef /\ OgmiosTxOut) -> Aeson - encode (inp /\ out) = encodeAeson $ - { "transaction": { "id": inp.txId } - , "index": inp.index - , "address": out.address - , "datumHash": out.datumHash - , "datum": out.datum - , "script": encodeScriptRef <$> out.script - , "value": encodeValue out.value +ogmiosQueryParams + :: forall a p + . DecodeOgmios a + => EncodeAeson p + => String + -> p + -> QueryM (Either OgmiosDecodeError a) +ogmiosQueryParams method params = do + let + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , id: "http-" <> method + , method + , params: params } - - encodeNativeScript :: NativeScript -> Aeson - encodeNativeScript (ScriptPubkey s) = - encodeAeson { "clause": "signature", "from": encodeAeson s } - encodeNativeScript (ScriptAll ss) = - encodeAeson { "clause": "all", "from": encodeNativeScript <$> ss } - encodeNativeScript (ScriptAny ss) = - encodeAeson { "clause": "any", "from": encodeNativeScript <$> ss } - encodeNativeScript (ScriptNOfK n ss) = - encodeAeson - { "clause": "some" - , "atLeast": BigInt.fromInt n - , "from": encodeNativeScript <$> ss - } - encodeNativeScript (TimelockStart (Slot n)) = - encodeAeson { "clause": "after", "slot": n } - encodeNativeScript (TimelockExpiry (Slot n)) = - encodeAeson { "clause": "before", "slot": n } - - encodeScriptRef :: ScriptRef -> Aeson - encodeScriptRef (NativeScriptRef s) = - encodeAeson - { "language": "native" - -- NOTE: We omit the cbor argument. - , "json": (encodeNativeScript s) - } - encodeScriptRef (PlutusScriptRef (PlutusScript (script /\ lang))) = - encodeAeson - { "language": - case lang of - PlutusV1 -> "plutus:v1" - PlutusV2 -> "plutus:v2" - PlutusV3 -> "plutus:v3" - , "cbor": byteArrayToHex script - } - - encodeValue :: Value -> Aeson - encodeValue value = encodeMap $ map encodeMap $ Map.union adaPart nonAdaPart - where - adaPart = Map.fromFoldable - [ ( "ada" /\ - ( Map.fromFoldable - [ ("lovelace" /\ (value # valueToCoin # unwrap)) ] - ) - ) - ] - nonAdaPart = mapKeys (byteArrayToHex <<< unwrap <<< encodeCbor) - $ map (mapKeys (byteArrayToHex <<< unAssetName)) - $ unwrap - $ getMultiAsset value - - mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a - mapKeys f = (Map.toUnfoldable :: Map k1 a -> Array (k1 /\ a)) >>> foldl - (\m' (k /\ v) -> Map.insert (f k) v m') - Map.empty - --- helper for assuming we get an object -aesonObject - :: forall (a :: Type) - . (Object Aeson -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonObject = caseAesonObject (Left (TypeMismatch "Expected Object")) - --- helper for assuming we get an array -aesonArray - :: forall (a :: Type) - . (Array Aeson -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonArray = caseAesonArray (Left (TypeMismatch "Expected Array")) - --------------------------------------------------------------------------------- --- Helpers --------------------------------------------------------------------------------- + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body ogmiosPostRequest :: Aeson -- ^ JSON-RPC request body diff --git a/src/Internal/QueryM/Pools.purs b/src/Internal/QueryM/Pools.purs index 499cab5ced..ec63b050dd 100644 --- a/src/Internal/QueryM/Pools.purs +++ b/src/Internal/QueryM/Pools.purs @@ -17,7 +17,7 @@ import Control.Monad.Error.Class (throwError) import Ctl.Internal.Helpers (liftM) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) -import Ctl.Internal.QueryM.Ogmios as OgmiosHttp +import Ctl.Internal.QueryM.Ogmios as Ogmios import Ctl.Internal.QueryM.Ogmios.Types (PoolParameters) import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) import Data.ByteArray (byteArrayToHex) @@ -36,7 +36,7 @@ getStakePools :: Maybe (Array PoolPubKeyHash) -> QueryM (Map PoolPubKeyHash PoolParameters) getStakePools selected = do - resp <- OgmiosHttp.poolParameters $ wrap selected + resp <- Ogmios.poolParameters $ wrap selected case resp of Left err -> throwError $ error $ pprintOgmiosDecodeError err Right val -> pure $ unwrap val @@ -71,7 +71,7 @@ getPoolsParameters poolPubKeyHashes = do getValidatorHashDelegationsAndRewards :: StakeValidatorHash -> QueryM (Maybe DelegationsAndRewards) getValidatorHashDelegationsAndRewards skh = do - resp <- OgmiosHttp.delegationsAndRewards [ stringRep ] + resp <- Ogmios.delegationsAndRewards [ stringRep ] case resp of Left err -> throwError $ error $ pprintOgmiosDecodeError err Right val -> pure $ Map.lookup byteHex $ unwrap val @@ -86,7 +86,7 @@ getValidatorHashDelegationsAndRewards skh = do getPubKeyHashDelegationsAndRewards :: StakePubKeyHash -> QueryM (Maybe DelegationsAndRewards) getPubKeyHashDelegationsAndRewards pkh = do - resp <- OgmiosHttp.delegationsAndRewards [ stringRep ] + resp <- Ogmios.delegationsAndRewards [ stringRep ] case resp of Left err -> throwError $ error $ pprintOgmiosDecodeError err Right val -> pure $ Map.lookup byteHex $ unwrap val diff --git a/src/Internal/Types/Interval.purs b/src/Internal/Types/Interval.purs index a7fc5c3c24..f53368150c 100644 --- a/src/Internal/Types/Interval.purs +++ b/src/Internal/Types/Interval.purs @@ -104,7 +104,7 @@ import Ctl.Internal.Helpers , showWithParens , unsafeFromJust ) -import Ctl.Internal.QueryM.Ogmios (aesonObject) +import Ctl.Internal.QueryM.Ogmios.Types (aesonObject) import Ctl.Internal.Types.SystemStart (SystemStart, sysStartUnixTime) import Data.Argonaut.Encode.Encoders (encodeString) import Data.Array (find, head, index, length) From 5f963f13885b3a6f871832cb2e54f43c0b198fd9 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 13:37:09 -0300 Subject: [PATCH 07/27] Move mempool related types to `Ogmios.Mempool` --- src/Contract/Backend/Ogmios/Mempool.purs | 2 +- src/Internal/QueryM/Ogmios/Mempool.purs | 202 +++++++++++++++++------ src/Internal/QueryM/Ogmios/Types.purs | 110 +----------- test/Ogmios/Aeson.purs | 11 +- test/Testnet/Contract/OgmiosMempool.purs | 2 +- 5 files changed, 166 insertions(+), 161 deletions(-) diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index a6a41b0358..18c077396a 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -36,7 +36,7 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , releaseMempoolCall , underlyingWebSocket ) -import Ctl.Internal.QueryM.Ogmios.Types +import Ctl.Internal.QueryM.Ogmios.Mempool ( MempoolSizeAndCapacity , MempoolSnapshotAcquired , MempoolTransaction(MempoolTransaction) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index 686d8ee206..bf69a6ac76 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -1,5 +1,11 @@ module Ctl.Internal.QueryM.Ogmios.Mempool - ( acquireMempoolSnapshotAff + ( ReleasedMempool(ReleasedMempool) + , MempoolSizeAndCapacity(MempoolSizeAndCapacity) + , MempoolSnapshotAcquired + , MempoolTransaction(MempoolTransaction) + , HasTxR(HasTxR) + , MaybeMempoolTransaction(MaybeMempoolTransaction) + , acquireMempoolSnapshotAff , mempoolSnapshotHasTxAff , mempoolSnapshotNextTxAff , mempoolSnapshotSizeAndCapacityAff @@ -30,15 +36,22 @@ module Ctl.Internal.QueryM.Ogmios.Mempool import Prelude import Aeson - ( class EncodeAeson + ( class DecodeAeson + , class EncodeAeson , Aeson - , JsonDecodeError(TypeMismatch) + , JsonDecodeError(UnexpectedValue, TypeMismatch) + , decodeAeson , encodeAeson + , getField , parseJsonStringToAeson , stringifyAeson + , (.:) ) +import Cardano.Provider.TxEvaluation (OgmiosTxId) import Cardano.Types.CborBytes (CborBytes) +import Cardano.Types.Slot (Slot) import Cardano.Types.TransactionHash (TransactionHash) +import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftEither, throwError) import Ctl.Internal.Logging (Logger) import Ctl.Internal.QueryM.JsonRpc2 @@ -47,6 +60,7 @@ import Ctl.Internal.QueryM.JsonRpc2 , JsonRpc2Request , OgmiosDecodeError , decodeOgmios + , decodeResult , mkCallType , ogmiosDecodeErrorToError ) @@ -77,38 +91,33 @@ import Ctl.Internal.QueryM.Ogmios.JsWebSocket ) import Ctl.Internal.QueryM.Ogmios.Types ( AdditionalUtxoSet + , ChainTipQR + , CurrentEpoch , DelegationsAndRewardsR - , HasTxR - , MaybeMempoolTransaction + , OgmiosEraSummaries , OgmiosProtocolParameters + , OgmiosSystemStart , OgmiosTxEvaluationR , PoolParametersR - , ReleasedMempool , StakePoolsQueryArgument - ) -import Ctl.Internal.QueryM.Ogmios.Types - ( ChainTipQR - , CurrentEpoch - , HasTxR - , MaybeMempoolTransaction - , MempoolSizeAndCapacity - , MempoolSnapshotAcquired - , MempoolTransaction - , OgmiosEraSummaries - , OgmiosSystemStart - , ReleasedMempool , SubmitTxR + , aesonNull + , aesonObject + , aesonString , submitSuccessPartialResp - ) as Ogmios + ) import Ctl.Internal.QueryM.UniqueId (ListenerId) import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) +import Data.Argonaut.Encode.Encoders as Argonaut import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right), either, isRight) import Data.Foldable (foldl) +import Data.Generic.Rep (class Generic) import Data.Log.Level (LogLevel(Error, Debug)) import Data.Map as Map import Data.Maybe (Maybe(Just, Nothing), maybe) -import Data.Newtype (unwrap, wrap) +import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Show.Generic (genericShow) import Data.Traversable (for_, traverse_) import Data.Tuple (fst) import Data.Tuple.Nested (type (/\), (/\)) @@ -123,7 +132,7 @@ import Effect.Ref as Ref -------------------------------------------------------------------------------- acquireMempoolSnapshotAff - :: OgmiosWebSocket -> Logger -> Aff Ogmios.MempoolSnapshotAcquired + :: OgmiosWebSocket -> Logger -> Aff MempoolSnapshotAcquired acquireMempoolSnapshotAff ogmiosWs logger = mkOgmiosRequestAff ogmiosWs logger acquireMempoolSnapshotCall _.acquireMempool @@ -132,7 +141,7 @@ acquireMempoolSnapshotAff ogmiosWs logger = mempoolSnapshotHasTxAff :: OgmiosWebSocket -> Logger - -> Ogmios.MempoolSnapshotAcquired + -> MempoolSnapshotAcquired -> TransactionHash -> Aff Boolean mempoolSnapshotHasTxAff ogmiosWs logger ms txh = @@ -144,8 +153,8 @@ mempoolSnapshotHasTxAff ogmiosWs logger ms txh = mempoolSnapshotSizeAndCapacityAff :: OgmiosWebSocket -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> Aff Ogmios.MempoolSizeAndCapacity + -> MempoolSnapshotAcquired + -> Aff MempoolSizeAndCapacity mempoolSnapshotSizeAndCapacityAff ogmiosWs logger ms = mkOgmiosRequestAff ogmiosWs logger (mempoolSnapshotSizeAndCapacityCall ms) @@ -155,7 +164,7 @@ mempoolSnapshotSizeAndCapacityAff ogmiosWs logger ms = releaseMempoolAff :: OgmiosWebSocket -> Logger - -> Ogmios.MempoolSnapshotAcquired + -> MempoolSnapshotAcquired -> Aff ReleasedMempool releaseMempoolAff ogmiosWs logger ms = mkOgmiosRequestAff ogmiosWs logger (releaseMempoolCall ms) @@ -165,48 +174,48 @@ releaseMempoolAff ogmiosWs logger ms = mempoolSnapshotNextTxAff :: OgmiosWebSocket -> Logger - -> Ogmios.MempoolSnapshotAcquired - -> Aff (Maybe Ogmios.MempoolTransaction) + -> MempoolSnapshotAcquired + -> Aff (Maybe MempoolTransaction) mempoolSnapshotNextTxAff ogmiosWs logger ms = unwrap <$> mkOgmiosRequestAff ogmiosWs logger (mempoolSnapshotNextTxCall ms) _.mempoolNextTx unit -acquireMempoolSnapshotCall :: JsonRpc2Call Unit Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshotCall :: JsonRpc2Call Unit MempoolSnapshotAcquired acquireMempoolSnapshotCall = mkOgmiosCallTypeNoArgs "acquireMempool" mempoolSnapshotHasTxCall - :: Ogmios.MempoolSnapshotAcquired - -> JsonRpc2Call TransactionHash Ogmios.HasTxR + :: MempoolSnapshotAcquired + -> JsonRpc2Call TransactionHash HasTxR mempoolSnapshotHasTxCall _ = mkOgmiosCallType { method: "hasTransaction" , params: { id: _ } } mempoolSnapshotNextTxCall - :: Ogmios.MempoolSnapshotAcquired - -> JsonRpc2Call Unit Ogmios.MaybeMempoolTransaction + :: MempoolSnapshotAcquired + -> JsonRpc2Call Unit MaybeMempoolTransaction mempoolSnapshotNextTxCall _ = mkOgmiosCallType { method: "nextTransaction" , params: const { fields: "all" } } mempoolSnapshotSizeAndCapacityCall - :: Ogmios.MempoolSnapshotAcquired - -> JsonRpc2Call Unit Ogmios.MempoolSizeAndCapacity + :: MempoolSnapshotAcquired + -> JsonRpc2Call Unit MempoolSizeAndCapacity mempoolSnapshotSizeAndCapacityCall _ = mkOgmiosCallTypeNoArgs "sizeOfMempool" releaseMempoolCall - :: Ogmios.MempoolSnapshotAcquired -> JsonRpc2Call Unit Ogmios.ReleasedMempool + :: MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool releaseMempoolCall _ = mkOgmiosCallTypeNoArgs "releaseMempool" withMempoolSnapshot :: OgmiosWebSocket -> Logger - -> (Maybe Ogmios.MempoolSnapshotAcquired -> Aff Unit) + -> (Maybe MempoolSnapshotAcquired -> Aff Unit) -> Effect Unit withMempoolSnapshot ogmiosWs logger cont = flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of @@ -362,7 +371,7 @@ resendPendingSubmitRequests label <> ": " <> show value <> " TransactionHash: " <> show txHash handlePendingSubmitRequest - :: Ogmios.MempoolSnapshotAcquired + :: MempoolSnapshotAcquired -> ListenerId -> RequestBody -> TransactionHash @@ -386,11 +395,11 @@ resendPendingSubmitRequests dispatchMap <- Ref.read dispatcher Ref.modify_ (Map.delete listenerId) dispatcher Map.lookup listenerId dispatchMap # - maybe (pure unit) (_ $ submitSuccessPartialResp) + maybe (pure unit) (_ $ submitSuccessPartialRespInner) where - submitSuccessPartialResp :: Aeson - submitSuccessPartialResp = - encodeAeson $ Ogmios.submitSuccessPartialResp txHash + submitSuccessPartialRespInner :: Aeson + submitSuccessPartialRespInner = + encodeAeson $ submitSuccessPartialResp txHash -------------------------------------------------------------------------------- -- `MkServiceWebSocketLens` for ogmios @@ -468,19 +477,19 @@ mkOgmiosWebSocketLens logger isTxConfirmed = do -------------------------------------------------------------------------------- type OgmiosListeners = - { chainTip :: ListenerSet Unit Ogmios.ChainTipQR + { chainTip :: ListenerSet Unit ChainTipQR , submit :: SubmitTxListenerSet , evaluate :: ListenerSet (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR , getProtocolParameters :: ListenerSet Unit OgmiosProtocolParameters - , eraSummaries :: ListenerSet Unit Ogmios.OgmiosEraSummaries - , currentEpoch :: ListenerSet Unit Ogmios.CurrentEpoch - , systemStart :: ListenerSet Unit Ogmios.OgmiosSystemStart - , acquireMempool :: ListenerSet Unit Ogmios.MempoolSnapshotAcquired + , eraSummaries :: ListenerSet Unit OgmiosEraSummaries + , currentEpoch :: ListenerSet Unit CurrentEpoch + , systemStart :: ListenerSet Unit OgmiosSystemStart + , acquireMempool :: ListenerSet Unit MempoolSnapshotAcquired , releaseMempool :: ListenerSet Unit ReleasedMempool , mempoolHasTx :: ListenerSet TransactionHash HasTxR , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction - , mempoolSizeAndCapacity :: ListenerSet Unit Ogmios.MempoolSizeAndCapacity + , mempoolSizeAndCapacity :: ListenerSet Unit MempoolSizeAndCapacity , stakePools :: ListenerSet StakePoolsQueryArgument PoolParametersR , delegationsAndRewards :: ListenerSet (Array String) DelegationsAndRewardsR } @@ -499,7 +508,7 @@ type ListenerSet (request :: Type) (response :: Type) = } type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) - Ogmios.SubmitTxR + SubmitTxR mkAddMessageListener :: forall (response :: Type) @@ -651,3 +660,100 @@ messageFoldF msg acc' func = do acc <- acc' if isRight acc then acc' else func msg +-------------------------------------------------------------------------------- + +-- Local Tx Monitor Query Response & Parsing +-------------------------------------------------------------------------------- + +newtype HasTxR = HasTxR Boolean + +derive instance Newtype HasTxR _ + +instance DecodeOgmios HasTxR where + decodeOgmios = decodeResult (map HasTxR <<< decodeAeson) + +newtype MempoolSnapshotAcquired = AwaitAcquired Slot + +instance Show MempoolSnapshotAcquired where + show (AwaitAcquired slot) = "(AwaitAcquired " <> show slot <> ")" + +instance DecodeAeson MempoolSnapshotAcquired where + decodeAeson = + -- todo: ignoring "acquired": "mempool" + map AwaitAcquired <<< aesonObject (flip getField "slot") + +instance DecodeOgmios MempoolSnapshotAcquired where + decodeOgmios = decodeResult decodeAeson + +-- | The acquired snapshot’s size (in bytes), number of transactions, and capacity +-- | (in bytes). +newtype MempoolSizeAndCapacity = MempoolSizeAndCapacity + { capacity :: Prim.Int + , currentSize :: Prim.Int + , numberOfTxs :: Prim.Int + } + +derive instance Generic MempoolSizeAndCapacity _ +derive instance Newtype MempoolSizeAndCapacity _ + +instance Show MempoolSizeAndCapacity where + show = genericShow + +instance DecodeAeson MempoolSizeAndCapacity where + decodeAeson = aesonObject \o -> do + capacity <- getField o "maxCapacity" >>= flip getField "bytes" + currentSize <- getField o "currentSize" >>= flip getField "bytes" + numberOfTxs <- getField o "transactions" >>= flip getField "count" + pure $ wrap { capacity, currentSize, numberOfTxs } + +instance DecodeOgmios MempoolSizeAndCapacity where + decodeOgmios = decodeResult decodeAeson + +newtype MempoolTransaction = MempoolTransaction + { id :: OgmiosTxId + , raw :: String -- hex encoded transaction cbor + } + +derive instance Generic MempoolTransaction _ +derive instance Newtype MempoolTransaction _ + +newtype MaybeMempoolTransaction = MaybeMempoolTransaction + (Maybe MempoolTransaction) + +instance DecodeAeson MaybeMempoolTransaction where + decodeAeson aeson = do + { transaction: tx } :: { transaction :: Aeson } <- decodeAeson aeson + res <- + ( do + tx' :: { id :: String, cbor :: String } <- decodeAeson tx + pure $ Just $ MempoolTransaction { id: tx'.id, raw: tx'.cbor } + ) <|> + ( do + aesonNull tx + pure Nothing + ) + pure $ MaybeMempoolTransaction $ res + +derive instance Newtype MaybeMempoolTransaction _ + +instance DecodeOgmios MaybeMempoolTransaction where + decodeOgmios = decodeResult decodeAeson + +data ReleasedMempool = ReleasedMempool + +derive instance Generic ReleasedMempool _ + +instance Show ReleasedMempool where + show = genericShow + +instance DecodeAeson ReleasedMempool where + decodeAeson = aesonObject \o -> do + released <- o .: "released" + flip aesonString released $ \s -> + if s == "mempool" then + pure $ ReleasedMempool + else + Left (UnexpectedValue $ Argonaut.encodeString s) + +instance DecodeOgmios ReleasedMempool where + decodeOgmios = decodeResult decodeAeson diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index 90972784e8..b80e918e31 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -6,28 +6,24 @@ module Ctl.Internal.QueryM.Ogmios.Types , ChainTipQR(CtChainOrigin, CtChainPoint) , CurrentEpoch(CurrentEpoch) , DelegationsAndRewardsR(DelegationsAndRewardsR) - , MempoolSizeAndCapacity(MempoolSizeAndCapacity) - , MempoolSnapshotAcquired - , MempoolTransaction(MempoolTransaction) , OgmiosBlockHeaderHash(OgmiosBlockHeaderHash) , OgmiosProtocolParameters(OgmiosProtocolParameters) , PParamRational(PParamRational) , PoolParameters , PoolParametersR(PoolParametersR) - , ReleasedMempool(ReleasedMempool) , AdditionalUtxoSet(AdditionalUtxoSet) , OgmiosUtxoMap , OgmiosEraSummaries(OgmiosEraSummaries) , OgmiosSystemStart(OgmiosSystemStart) , SubmitTxR(SubmitTxSuccess, SubmitFail) , StakePoolsQueryArgument(StakePoolsQueryArgument) - , HasTxR(HasTxR) - , MaybeMempoolTransaction(MaybeMempoolTransaction) , OgmiosTxEvaluationR(OgmiosTxEvaluationR) , aesonObject , submitSuccessPartialResp , parseIpv6String , rationalToSubcoin + , aesonNull + , aesonString ) where import Prelude @@ -36,7 +32,7 @@ import Aeson ( class DecodeAeson , class EncodeAeson , Aeson - , JsonDecodeError(AtKey, TypeMismatch, UnexpectedValue, MissingValue) + , JsonDecodeError(TypeMismatch, MissingValue, AtKey) , caseAesonArray , caseAesonNull , caseAesonObject @@ -54,7 +50,6 @@ import Aeson import Cardano.AsCbor (decodeCbor, encodeCbor) import Cardano.Provider.TxEvaluation ( ExecutionUnits - , OgmiosTxId , OgmiosTxOut , OgmiosTxOutRef , RedeemerPointer @@ -142,7 +137,6 @@ import Ctl.Internal.Types.SystemStart , sysStartFromOgmiosTimestamp , sysStartToOgmiosTimestamp ) -import Data.Argonaut.Encode.Encoders as Argonaut import Data.Array (catMaybes) import Data.Array (fromFoldable, length, replicate) as Array import Data.Bifunctor (lmap) @@ -172,104 +166,6 @@ import JS.BigInt as BigInt import Untagged.TypeCheck (class HasRuntimeType) import Untagged.Union (type (|+|), toEither1) --------------------------------------------------------------------------------- - --- Local Tx Monitor Query Response & Parsing --------------------------------------------------------------------------------- - -newtype HasTxR = HasTxR Boolean - -derive instance Newtype HasTxR _ - -instance DecodeOgmios HasTxR where - decodeOgmios = decodeResult (map HasTxR <<< decodeAeson) - -newtype MempoolSnapshotAcquired = AwaitAcquired Slot - -instance Show MempoolSnapshotAcquired where - show (AwaitAcquired slot) = "(AwaitAcquired " <> show slot <> ")" - -instance DecodeAeson MempoolSnapshotAcquired where - decodeAeson = - -- todo: ignoring "acquired": "mempool" - map AwaitAcquired <<< aesonObject (flip getField "slot") - -instance DecodeOgmios MempoolSnapshotAcquired where - decodeOgmios = decodeResult decodeAeson - --- | The acquired snapshot’s size (in bytes), number of transactions, and capacity --- | (in bytes). -newtype MempoolSizeAndCapacity = MempoolSizeAndCapacity - { capacity :: Prim.Int - , currentSize :: Prim.Int - , numberOfTxs :: Prim.Int - } - -derive instance Generic MempoolSizeAndCapacity _ -derive instance Newtype MempoolSizeAndCapacity _ - -instance Show MempoolSizeAndCapacity where - show = genericShow - -instance DecodeAeson MempoolSizeAndCapacity where - decodeAeson = aesonObject \o -> do - capacity <- getField o "maxCapacity" >>= flip getField "bytes" - currentSize <- getField o "currentSize" >>= flip getField "bytes" - numberOfTxs <- getField o "transactions" >>= flip getField "count" - pure $ wrap { capacity, currentSize, numberOfTxs } - -instance DecodeOgmios MempoolSizeAndCapacity where - decodeOgmios = decodeResult decodeAeson - -newtype MempoolTransaction = MempoolTransaction - { id :: OgmiosTxId - , raw :: String -- hex encoded transaction cbor - } - -derive instance Generic MempoolTransaction _ -derive instance Newtype MempoolTransaction _ - -newtype MaybeMempoolTransaction = MaybeMempoolTransaction - (Maybe MempoolTransaction) - -instance DecodeAeson MaybeMempoolTransaction where - decodeAeson aeson = do - { transaction: tx } :: { transaction :: Aeson } <- decodeAeson aeson - res <- - ( do - tx' :: { id :: String, cbor :: String } <- decodeAeson tx - pure $ Just $ MempoolTransaction { id: tx'.id, raw: tx'.cbor } - ) <|> - ( do - aesonNull tx - pure Nothing - ) - pure $ MaybeMempoolTransaction $ res - -derive instance Newtype MaybeMempoolTransaction _ - -instance DecodeOgmios MaybeMempoolTransaction where - decodeOgmios = decodeResult decodeAeson - -data ReleasedMempool = ReleasedMempool - -derive instance Generic ReleasedMempool _ - -instance Show ReleasedMempool where - show = genericShow - -instance DecodeAeson ReleasedMempool where - decodeAeson = aesonObject \o -> do - released <- o .: "released" - flip aesonString released $ \s -> - if s == "mempool" then - pure $ ReleasedMempool - else - Left (UnexpectedValue $ Argonaut.encodeString s) - -instance DecodeOgmios ReleasedMempool where - decodeOgmios = decodeResult decodeAeson - ---------------- TX SUBMISSION QUERY RESPONSE & PARSING submitSuccessPartialResp diff --git a/test/Ogmios/Aeson.purs b/test/Ogmios/Aeson.purs index a85e6c992d..059fa6d0e5 100644 --- a/test/Ogmios/Aeson.purs +++ b/test/Ogmios/Aeson.purs @@ -15,9 +15,12 @@ import Ctl.Internal.QueryM.JsonRpc2 , OgmiosDecodeError(ErrorResponse) , decodeOgmios ) -import Ctl.Internal.QueryM.Ogmios.Types +import Ctl.Internal.QueryM.Ogmios.Mempool ( HasTxR - , OgmiosTxEvaluationR + , MempoolSizeAndCapacity + ) as Mempool +import Ctl.Internal.QueryM.Ogmios.Types + ( OgmiosTxEvaluationR , SubmitTxR , aesonObject ) @@ -65,8 +68,8 @@ tested = ) , ("evaluateTransaction" /\ check (Proxy :: _ OgmiosTxEvaluationR)) , ("submitTransaction" /\ check (Proxy :: _ SubmitTxR)) - , ("hasTransaction" /\ check (Proxy :: _ HasTxR)) - , ("sizeOfMempool" /\ check (Proxy :: _ O.MempoolSizeAndCapacity)) + , ("hasTransaction" /\ check (Proxy :: _ Mempool.HasTxR)) + , ("sizeOfMempool" /\ check (Proxy :: _ Mempool.MempoolSizeAndCapacity)) -- ignoring because response may lack tx cbor if not run with flag -- This endpoint is tested with "fetchMempoolTXs" test (Test.Ctl.Plutip.Contract.OgmiosMempool) -- , ("nextTransaction" /\ (Proxy :: _ MaybeMempoolTransaction )) diff --git a/test/Testnet/Contract/OgmiosMempool.purs b/test/Testnet/Contract/OgmiosMempool.purs index 33c38ae55d..c3b315b598 100644 --- a/test/Testnet/Contract/OgmiosMempool.purs +++ b/test/Testnet/Contract/OgmiosMempool.purs @@ -17,7 +17,7 @@ import Contract.Test (ContractTest, InitialUTxOs, withKeyWallet, withWallets) import Contract.Test.Mote (TestPlanM) import Contract.Transaction (awaitTxConfirmed) import Ctl.Examples.PlutusV2.InlineDatum as InlineDatum -import Ctl.Internal.QueryM.Ogmios.Types +import Ctl.Internal.QueryM.Ogmios.Mempool ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) ) import Data.Array (length) From 5c2d73f2f2f3870b03c7d4df720655ee0f531dc3 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 13:41:36 -0300 Subject: [PATCH 08/27] Fix IPV6 parser --- src/Internal/QueryM/Ogmios/Types.purs | 2 +- test/Types/Ipv6.purs | 19 +++++++++++-------- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index b80e918e31..97b810141a 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -471,7 +471,7 @@ parseIpv6String str = do padded = String.replaceAll (Pattern " ") (Replacement "0") $ fold $ partsFixed <#> StringUtils.padStart 4 - decodeCbor <<< wrap =<< hexToByteArray padded + decodeCbor <<< wrap =<< hexToByteArray ("50" <> padded) decodeRelay :: Aeson -> Either JsonDecodeError Relay decodeRelay aeson = do diff --git a/test/Types/Ipv6.purs b/test/Types/Ipv6.purs index 12b77288de..832de7b223 100644 --- a/test/Types/Ipv6.purs +++ b/test/Types/Ipv6.purs @@ -7,25 +7,28 @@ import Prelude import Cardano.AsCbor (decodeCbor) import Ctl.Internal.QueryM.Ogmios.Types (parseIpv6String) import Data.ByteArray (hexToByteArrayUnsafe) +import Data.Maybe (Maybe(Nothing)) import Data.Newtype (wrap) import Effect.Aff (Aff) import Mote (group, test) import Mote.TestPlanM (TestPlanM) -import Test.Spec.Assertions (shouldEqual) +import Test.Spec.Assertions (shouldEqual, shouldNotEqual) suite :: TestPlanM (Aff Unit) Unit suite = do group "Ipv6 type (parsing)" do testIpv6 "2345:425:2CA1:0000:0000:567:5673:23b5" - "234504252CA1000000000567567323b5" + "50234504252CA1000000000567567323b5" testIpv6 "2345:0425:2CA1:0:0:0567:5673:23b5" - "234504252CA1000000000567567323b5" - testIpv6 "2345:0425:2CA1::0567:5673:23b5" "234504252CA1000000000567567323b5" - testIpv6 "2345:0425:2CA1::5673:23b5" "234504252CA1000000000000567323b5" - testIpv6 "2345:0425:2CA1::23b5" "234504252CA1000000000000000023b5" + "50234504252CA1000000000567567323b5" + testIpv6 "2345:0425:2CA1::0567:5673:23b5" + "50234504252CA1000000000567567323b5" + testIpv6 "2345:0425:2CA1::5673:23b5" "50234504252CA1000000000000567323b5" + testIpv6 "2345:0425:2CA1::23b5" "50234504252CA1000000000000000023b5" testIpv6 :: String -> String -> TestPlanM (Aff Unit) Unit testIpv6 str expected = test str do - parseIpv6String str `shouldEqual` - (decodeCbor (wrap $ hexToByteArrayUnsafe expected)) + let ipv6 = parseIpv6String str + ipv6 `shouldNotEqual` Nothing + ipv6 `shouldEqual` (decodeCbor (wrap $ hexToByteArrayUnsafe expected)) From 2c0c04db2aa12999a984dba10703c85786d47a4f Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 14:31:55 -0300 Subject: [PATCH 09/27] Move `DecodeOgmios` to `Ogmios.Types` --- src/Contract/Backend/Ogmios/Mempool.purs | 2 +- src/Internal/Contract/Monad.purs | 5 +- src/Internal/QueryM.purs | 4 +- src/Internal/QueryM/CurrentEpoch.purs | 3 +- src/Internal/QueryM/EraSummaries.purs | 2 +- src/Internal/QueryM/JsonRpc2.purs | 242 --------------------- src/Internal/QueryM/Ogmios.purs | 12 +- src/Internal/QueryM/Ogmios/Dispatcher.purs | 2 +- src/Internal/QueryM/Ogmios/JsonRpc2.purs | 88 ++++++++ src/Internal/QueryM/Ogmios/Mempool.purs | 30 +-- src/Internal/QueryM/Ogmios/Types.purs | 154 ++++++++++++- src/Internal/QueryM/Pools.purs | 6 +- test/Ogmios/Aeson.purs | 10 +- test/Ogmios/EvaluateTx.purs | 4 +- test/Ogmios/GenerateFixtures.purs | 3 +- 15 files changed, 276 insertions(+), 291 deletions(-) delete mode 100644 src/Internal/QueryM/JsonRpc2.purs create mode 100644 src/Internal/QueryM/Ogmios/JsonRpc2.purs diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index 18c077396a..eede83e532 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -22,8 +22,8 @@ import Control.Monad.Reader.Trans (asks) import Ctl.Internal.Contract.Monad (wrapQueryM) import Ctl.Internal.Logging (Logger, mkLogger) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.JsWebSocket (JsWebSocket) +import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , OgmiosListeners diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index 335c6619ae..226ff39f3c 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -56,7 +56,6 @@ import Ctl.Internal.Contract.ProviderBackend import Ctl.Internal.Helpers (filterMapWithKeyM, liftM, logWithLevel) import Ctl.Internal.Logging (Logger, mkLogger, setupLogs) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.JsonRpc2 (OgmiosDecodeError, pprintOgmiosDecodeError) import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) import Ctl.Internal.QueryM.Ogmios ( getProtocolParameters @@ -69,6 +68,10 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , underlyingWebSocket ) import Ctl.Internal.QueryM.Ogmios.Queries (QueryEnv) +import Ctl.Internal.QueryM.Ogmios.Types + ( OgmiosDecodeError + , pprintOgmiosDecodeError + ) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 105544cdba..f882c8902c 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -1,7 +1,5 @@ -- | CTL query layer monad. --- | This module defines an Aff interface for Ogmios Websocket Queries. --- | Since WebSockets do not define a mechanism for linking request/response. --- | Or for verifying that the connection is live, those concerns are addressed here +-- | This module defines an Aff interface for backend queries. module Ctl.Internal.QueryM ( QueryM , ParQueryM diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index beee5ec079..c01c2f0131 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -7,9 +7,8 @@ import Prelude import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) import Ctl.Internal.QueryM.Ogmios (currentEpoch) as Ogmios -import Ctl.Internal.QueryM.Ogmios.Types (CurrentEpoch) +import Ctl.Internal.QueryM.Ogmios.Types (CurrentEpoch, pprintOgmiosDecodeError) import Data.Either (Either(Right, Left)) import Effect.Exception (error) diff --git a/src/Internal/QueryM/EraSummaries.purs b/src/Internal/QueryM/EraSummaries.purs index 77e1c84c99..0eb8dafa6e 100644 --- a/src/Internal/QueryM/EraSummaries.purs +++ b/src/Internal/QueryM/EraSummaries.purs @@ -8,8 +8,8 @@ import Prelude import Cardano.Types.EraSummaries (EraSummaries) import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) import Ctl.Internal.QueryM.Ogmios (eraSummaries) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types (pprintOgmiosDecodeError) import Data.Either (Either(Right, Left)) import Data.Newtype (unwrap) import Effect.Exception (error) diff --git a/src/Internal/QueryM/JsonRpc2.purs b/src/Internal/QueryM/JsonRpc2.purs deleted file mode 100644 index 78603db09f..0000000000 --- a/src/Internal/QueryM/JsonRpc2.purs +++ /dev/null @@ -1,242 +0,0 @@ --- | Provides basics types and operations for working with JSON RPC protocol --- | used by Ogmios -module Ctl.Internal.QueryM.JsonRpc2 - ( JsonRpc2Call - , JsonRpc2Request - , buildRequest - , mkCallType - , JsonRpc2Response - , decodeResult - , ogmiosDecodeErrorToError - , OgmiosDecodeError - ( ResultDecodingError - , ClientErrorResponse - , InvalidResponse - , ErrorResponse - ) - , OgmiosError(OgmiosError) - , class DecodeOgmios - , decodeOgmios - , decodeErrorOrResult - , parseJsonRpc2ResponseId - , decodeAesonJsonRpc2Response - , pprintOgmiosDecodeError - , pprintOgmiosError - ) where - -import Prelude - -import Aeson - ( class DecodeAeson - , class EncodeAeson - , Aeson - , JsonDecodeError(TypeMismatch) - , caseAesonObject - , decodeAeson - , encodeAeson - , getField - , getFieldOptional - , printJsonDecodeError - , stringifyAeson - ) -import Cardano.Provider.Error (ClientError, pprintClientError) -import Ctl.Internal.QueryM.UniqueId (ListenerId, uniqueId) -import Data.Bifunctor (lmap) -import Data.Either (Either(Left, Right)) -import Data.Generic.Rep (class Generic) -import Data.Maybe (Maybe(Just), maybe) -import Data.Newtype (class Newtype) -import Data.Show.Generic (genericShow) -import Data.These (These(That, Both), theseLeft, theseRight) -import Data.Traversable (sequence) -import Data.Tuple.Nested ((/\)) -import Effect (Effect) -import Effect.Aff (Error, error) -import Foreign.Object (Object) -import Record as Record - --- | Structure of all json rpc2.0 websocket requests --- described in: https://ogmios.dev/getting-started/basics/ -type JsonRpc2Request (a :: Type) = - { jsonrpc :: String - , method :: String - , params :: a - , id :: ListenerId - } - --- | Convenience helper function for creating `JsonRpc2Request a` objects -mkJsonRpc2Request - :: forall (a :: Type) - . { jsonrpc :: String } - -> { method :: String - , params :: a - } - -> Effect (JsonRpc2Request a) -mkJsonRpc2Request service method = do - id <- uniqueId $ method.method <> "-" - pure - $ Record.merge { id } - $ Record.merge service method - --- | Structure of all json rpc websocket responses --- described in: https://ogmios.dev/getting-started/basics/ -type JsonRpc2Response = - { jsonrpc :: String - -- methodname is not always present if `error` is not empty - , method :: Maybe String - , result :: Maybe Aeson - , error :: Maybe Aeson - , id :: ListenerId - } - -decodeAesonJsonRpc2Response - :: Aeson -> Either JsonDecodeError JsonRpc2Response -decodeAesonJsonRpc2Response = aesonObject $ \o -> do - jsonrpc <- getField o "jsonrpc" - method <- getFieldOptional o "method" - result <- getFieldOptional o "result" - error <- getFieldOptional o "error" - id <- getField o "id" - pure - { jsonrpc - , method - , result - , error - , id - } - --- | A wrapper for tying arguments and response types to request building. -newtype JsonRpc2Call :: Type -> Type -> Type -newtype JsonRpc2Call (i :: Type) (o :: Type) = JsonRpc2Call - (i -> Effect { body :: Aeson, id :: String }) - --- | Creates a "jsonrpc call" which ties together request input and response output types --- | along with a way to create a request object. -mkCallType - :: forall (a :: Type) (i :: Type) (o :: Type) - . EncodeAeson (JsonRpc2Request a) - => { jsonrpc :: String } - -> { method :: String, params :: i -> a } - -> JsonRpc2Call i o -mkCallType service { method, params } = JsonRpc2Call \i -> do - req <- mkJsonRpc2Request service { method, params: params i } - pure { body: encodeAeson req, id: req.id } - --- | Create a JsonRpc2 request body and id -buildRequest - :: forall (i :: Type) (o :: Type) - . JsonRpc2Call i o - -> i - -> Effect { body :: Aeson, id :: String } -buildRequest (JsonRpc2Call c) = c - -newtype OgmiosError = OgmiosError - { code :: Int, message :: String, data :: Maybe Aeson } - -derive instance Generic OgmiosError _ -derive instance Newtype OgmiosError _ - -instance Show OgmiosError where - show = genericShow - -pprintOgmiosError :: OgmiosError -> String -pprintOgmiosError (OgmiosError err) = stringifyAeson $ encodeAeson err - -instance DecodeAeson OgmiosError where - decodeAeson = aesonObject \o -> do - code <- getField o "code" - message <- getField o "message" - dat <- getFieldOptional o "data" - pure $ OgmiosError { code, message, data: dat } - -data OgmiosDecodeError - -- Server responded with error. - = ErrorResponse (Maybe OgmiosError) - -- Server responded with result, parsing of which failed - | ClientErrorResponse ClientError - -- Server responded with result, parsing of which failed - | ResultDecodingError JsonDecodeError - -- Received JsonRpc2Response was not of the right format. - | InvalidResponse JsonDecodeError - -derive instance Generic OgmiosDecodeError _ - -instance Show OgmiosDecodeError where - show = genericShow - -pprintOgmiosDecodeError :: OgmiosDecodeError -> String -pprintOgmiosDecodeError (ErrorResponse err) = "Ogmios responded with error: " <> - maybe "" pprintOgmiosError err -pprintOgmiosDecodeError (ClientErrorResponse err) = - "Ogmios responded with error: " <> pprintClientError err -pprintOgmiosDecodeError (ResultDecodingError err) = - "Failed to parse the result: " <> printJsonDecodeError err -pprintOgmiosDecodeError (InvalidResponse err) = - "Ogmios response was not of the right format: " <> printJsonDecodeError err - -ogmiosDecodeErrorToError :: OgmiosDecodeError -> Error -ogmiosDecodeErrorToError err = error $ pprintOgmiosDecodeError err - --- | Variation of DecodeAeson for ogmios response, defines how to parse full ogmios reponse. --- We usually parse just the content of the "result" field, --- but sometimes also "error" field, hence a class other than DecodeAeson. -class DecodeOgmios o where - decodeOgmios :: Aeson -> Either OgmiosDecodeError o - --- | Given how to parse result or error fields, --- defines a parser of the full json2rpc response. -makeDecodeOgmios - :: forall o - . These - { parseError :: Aeson -> Either JsonDecodeError o } - { parseResult :: Aeson -> Either JsonDecodeError o } - -> Aeson - -> Either OgmiosDecodeError o -makeDecodeOgmios decoders aeson = do - json <- lmap InvalidResponse $ decodeAesonJsonRpc2Response aeson - let merr = _.parseError <$> theseLeft decoders <*> json.error - let mres = _.parseResult <$> theseRight decoders <*> json.result - case (mres /\ merr) of - -- Expected result, got it - Just (Right x) /\ _ -> pure x - -- Expected result, got it in a wrong format - Just (Left err) /\ _ -> Left $ ResultDecodingError err - -- Got an expected error - _ /\ Just (Right x) -> pure x - -- Got an unexpected error - _ -> do - err :: Maybe OgmiosError <- sequence $ - lmap InvalidResponse <<< decodeAeson <$> json.error - Left $ ErrorResponse err - --- | Decode "result" field of ogmios response. -decodeResult - :: forall o - . (Aeson -> Either JsonDecodeError o) - -> Aeson - -> Either OgmiosDecodeError o -decodeResult decodeAeson = makeDecodeOgmios $ That { parseResult: decodeAeson } - --- | Decode "result" field or if absent the error field of ogmios response. -decodeErrorOrResult - :: forall o - . { parseError :: (Aeson -> Either JsonDecodeError o) } - -> { parseResult :: (Aeson -> Either JsonDecodeError o) } - -> Aeson - -> Either OgmiosDecodeError o -decodeErrorOrResult err res = makeDecodeOgmios $ Both err res - --- | Parse just ID from the response -parseJsonRpc2ResponseId - :: Aeson - -> Either JsonDecodeError ListenerId -parseJsonRpc2ResponseId = - aesonObject $ flip getField "id" - --- | Helper for assuming we get an object -aesonObject - :: forall (a :: Type) - . (Object Aeson -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonObject = caseAesonObject (Left (TypeMismatch "expected object")) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 95516ea408..8a32de2b16 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -33,17 +33,13 @@ import Control.Monad.Error.Class (class MonadThrow, throwError) import Control.Monad.Reader.Class (asks) import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.JsonRpc2 - ( class DecodeOgmios - , OgmiosDecodeError(ResultDecodingError, ClientErrorResponse) - , decodeOgmios - , pprintOgmiosDecodeError - ) import Ctl.Internal.QueryM.Ogmios.Types - ( AdditionalUtxoSet + ( class DecodeOgmios + , AdditionalUtxoSet , ChainTipQR(CtChainPoint, CtChainOrigin) , CurrentEpoch , DelegationsAndRewardsR + , OgmiosDecodeError(ResultDecodingError, ClientErrorResponse) , OgmiosEraSummaries , OgmiosProtocolParameters , OgmiosSystemStart @@ -51,6 +47,8 @@ import Ctl.Internal.QueryM.Ogmios.Types , PoolParametersR , StakePoolsQueryArgument , SubmitTxR + , decodeOgmios + , pprintOgmiosDecodeError ) import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) import Data.Bifunctor (lmap) diff --git a/src/Internal/QueryM/Ogmios/Dispatcher.purs b/src/Internal/QueryM/Ogmios/Dispatcher.purs index b5b7a08f1d..b0bf90c0d2 100644 --- a/src/Internal/QueryM/Ogmios/Dispatcher.purs +++ b/src/Internal/QueryM/Ogmios/Dispatcher.purs @@ -16,7 +16,7 @@ import Prelude import Aeson (Aeson, JsonDecodeError, stringifyAeson) import Cardano.Types.TransactionHash (TransactionHash) -import Ctl.Internal.QueryM.JsonRpc2 (parseJsonRpc2ResponseId) +import Ctl.Internal.QueryM.Ogmios.JsonRpc2 (parseJsonRpc2ResponseId) import Ctl.Internal.QueryM.UniqueId (ListenerId) import Data.Either (Either(Left, Right)) import Data.Map (Map) diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/JsonRpc2.purs new file mode 100644 index 0000000000..76b55ca183 --- /dev/null +++ b/src/Internal/QueryM/Ogmios/JsonRpc2.purs @@ -0,0 +1,88 @@ +-- | Provides basics types and operations for working with JSON RPC protocol +-- | used by Ogmios +module Ctl.Internal.QueryM.Ogmios.JsonRpc2 + ( JsonRpc2Call + , JsonRpc2Request + , buildRequest + , mkCallType + , parseJsonRpc2ResponseId + ) where + +import Prelude + +import Aeson + ( class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch) + , caseAesonObject + , encodeAeson + , getField + ) +import Ctl.Internal.QueryM.UniqueId (ListenerId, uniqueId) +import Data.Either (Either(Left)) +import Effect (Effect) +import Foreign.Object (Object) +import Record as Record + +-- | Structure of all json rpc2.0 websocket requests +-- described in: https://ogmios.dev/getting-started/basics/ +type JsonRpc2Request (a :: Type) = + { jsonrpc :: String + , method :: String + , params :: a + , id :: ListenerId + } + +-- | Convenience helper function for creating `JsonRpc2Request a` objects +mkJsonRpc2Request + :: forall (a :: Type) + . { jsonrpc :: String } + -> { method :: String + , params :: a + } + -> Effect (JsonRpc2Request a) +mkJsonRpc2Request service method = do + id <- uniqueId $ method.method <> "-" + pure + $ Record.merge { id } + $ Record.merge service method + +-- | A wrapper for tying arguments and response types to request building. +newtype JsonRpc2Call :: Type -> Type -> Type +newtype JsonRpc2Call (i :: Type) (o :: Type) = JsonRpc2Call + (i -> Effect { body :: Aeson, id :: String }) + +-- | Creates a "jsonrpc call" which ties together request input and response output types +-- | along with a way to create a request object. +mkCallType + :: forall (a :: Type) (i :: Type) (o :: Type) + . EncodeAeson (JsonRpc2Request a) + => { jsonrpc :: String } + -> { method :: String, params :: i -> a } + -> JsonRpc2Call i o +mkCallType service { method, params } = JsonRpc2Call \i -> do + req <- mkJsonRpc2Request service { method, params: params i } + pure { body: encodeAeson req, id: req.id } + +-- | Create a JsonRpc2 request body and id +buildRequest + :: forall (i :: Type) (o :: Type) + . JsonRpc2Call i o + -> i + -> Effect { body :: Aeson, id :: String } +buildRequest (JsonRpc2Call c) = c + +-- | Parse just ID from the response +parseJsonRpc2ResponseId + :: Aeson + -> Either JsonDecodeError ListenerId +parseJsonRpc2ResponseId = + aesonObject $ flip getField "id" + +-- | Helper for assuming we get an object +aesonObject + :: forall (a :: Type) + . (Object Aeson -> Either JsonDecodeError a) + -> Aeson + -> Either JsonDecodeError a +aesonObject = caseAesonObject (Left (TypeMismatch "expected object")) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index bf69a6ac76..fc195c111d 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -54,17 +54,6 @@ import Cardano.Types.TransactionHash (TransactionHash) import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftEither, throwError) import Ctl.Internal.Logging (Logger) -import Ctl.Internal.QueryM.JsonRpc2 - ( class DecodeOgmios - , JsonRpc2Call - , JsonRpc2Request - , OgmiosDecodeError - , decodeOgmios - , decodeResult - , mkCallType - , ogmiosDecodeErrorToError - ) -import Ctl.Internal.QueryM.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Dispatcher ( DispatchError(JsonError) , Dispatcher @@ -89,11 +78,19 @@ import Ctl.Internal.QueryM.Ogmios.JsWebSocket , _wsFinalize , _wsSend ) +import Ctl.Internal.QueryM.Ogmios.JsonRpc2 + ( JsonRpc2Call + , JsonRpc2Request + , mkCallType + ) +import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Types - ( AdditionalUtxoSet + ( class DecodeOgmios + , AdditionalUtxoSet , ChainTipQR , CurrentEpoch , DelegationsAndRewardsR + , OgmiosDecodeError , OgmiosEraSummaries , OgmiosProtocolParameters , OgmiosSystemStart @@ -104,6 +101,9 @@ import Ctl.Internal.QueryM.Ogmios.Types , aesonNull , aesonObject , aesonString + , decodeOgmios + , decodeResult + , ogmiosDecodeErrorToError , submitSuccessPartialResp ) import Ctl.Internal.QueryM.UniqueId (ListenerId) @@ -512,10 +512,10 @@ type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) mkAddMessageListener :: forall (response :: Type) - . JsonRpc2.DecodeOgmios response + . DecodeOgmios response => Dispatcher -> ( ListenerId - -> (Either JsonRpc2.OgmiosDecodeError response -> Effect Unit) + -> (Either OgmiosDecodeError response -> Effect Unit) -> Effect Unit ) mkAddMessageListener dispatcher = @@ -538,7 +538,7 @@ mkRemoveMessageListener dispatcher pendingRequests = -- methods, this can be picked up by a query or cancellation function mkListenerSet :: forall (request :: Type) (response :: Type) - . JsonRpc2.DecodeOgmios response + . DecodeOgmios response => Dispatcher -> PendingRequests -> ListenerSet request response diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index 97b810141a..fc680fd2ec 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -13,6 +13,21 @@ module Ctl.Internal.QueryM.Ogmios.Types , PoolParametersR(PoolParametersR) , AdditionalUtxoSet(AdditionalUtxoSet) , OgmiosUtxoMap + , decodeResult + , decodeErrorOrResult + , decodeAesonJsonRpc2Response + , OgmiosError(OgmiosError) + , pprintOgmiosDecodeError + , ogmiosDecodeErrorToError + , decodeOgmios + , class DecodeOgmios + , JsonRpc2Response + , OgmiosDecodeError + ( ResultDecodingError + , ClientErrorResponse + , InvalidResponse + , ErrorResponse + ) , OgmiosEraSummaries(OgmiosEraSummaries) , OgmiosSystemStart(OgmiosSystemStart) , SubmitTxR(SubmitTxSuccess, SubmitFail) @@ -42,12 +57,15 @@ import Aeson , fromArray , fromString , getField + , getFieldOptional , isNull + , printJsonDecodeError , stringifyAeson , (.:) , (.:?) ) import Cardano.AsCbor (decodeCbor, encodeCbor) +import Cardano.Provider.Error (ClientError, pprintClientError) import Cardano.Provider.TxEvaluation ( ExecutionUnits , OgmiosTxOut @@ -121,12 +139,7 @@ import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) import Control.Alt ((<|>)) import Control.Alternative (guard) import Ctl.Internal.Helpers (encodeMap, showWithParens) -import Ctl.Internal.QueryM.JsonRpc2 - ( class DecodeOgmios - , OgmiosError - , decodeErrorOrResult - , decodeResult - ) +import Ctl.Internal.QueryM.UniqueId (ListenerId) import Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) ) @@ -156,10 +169,12 @@ import Data.String (Pattern(Pattern), Replacement(Replacement)) import Data.String (replaceAll) as String import Data.String.Common (split) as String import Data.String.Utils as StringUtils -import Data.Traversable (for, traverse) +import Data.These (These(That, Both), theseLeft, theseRight) +import Data.Traversable (for, sequence, traverse) import Data.Tuple (Tuple(Tuple)) import Data.Tuple.Nested (type (/\), (/\)) import Data.UInt (UInt) +import Effect.Aff (Error, error) import Foreign.Object (Object) import Foreign.Object as Object import JS.BigInt as BigInt @@ -1004,3 +1019,128 @@ aesonNull . Aeson -> Either JsonDecodeError Unit aesonNull = caseAesonNull (Left (TypeMismatch "Expected Null")) pure + +-- Decode utilities + +newtype OgmiosError = OgmiosError + { code :: Int, message :: String, data :: Maybe Aeson } + +derive instance Generic OgmiosError _ +derive instance Newtype OgmiosError _ + +instance Show OgmiosError where + show = genericShow + +pprintOgmiosError :: OgmiosError -> String +pprintOgmiosError (OgmiosError err) = stringifyAeson $ encodeAeson err + +instance DecodeAeson OgmiosError where + decodeAeson = aesonObject \o -> do + code <- getField o "code" + message <- getField o "message" + dat <- getFieldOptional o "data" + pure $ OgmiosError { code, message, data: dat } + +data OgmiosDecodeError + -- Server responded with error. + = ErrorResponse (Maybe OgmiosError) + -- Server responded with result, parsing of which failed + | ClientErrorResponse ClientError + -- Server responded with result, parsing of which failed + | ResultDecodingError JsonDecodeError + -- Received JsonRpc2Response was not of the right format. + | InvalidResponse JsonDecodeError + +derive instance Generic OgmiosDecodeError _ + +instance Show OgmiosDecodeError where + show = genericShow + +pprintOgmiosDecodeError :: OgmiosDecodeError -> String +pprintOgmiosDecodeError (ErrorResponse err) = "Ogmios responded with error: " <> + maybe "" pprintOgmiosError err +pprintOgmiosDecodeError (ClientErrorResponse err) = + "Ogmios responded with error: " <> pprintClientError err +pprintOgmiosDecodeError (ResultDecodingError err) = + "Failed to parse the result: " <> printJsonDecodeError err +pprintOgmiosDecodeError (InvalidResponse err) = + "Ogmios response was not of the right format: " <> printJsonDecodeError err + +ogmiosDecodeErrorToError :: OgmiosDecodeError -> Error +ogmiosDecodeErrorToError err = error $ pprintOgmiosDecodeError err + +-- | Variation of DecodeAeson for ogmios response, defines how to parse full ogmios reponse. +-- We usually parse just the content of the "result" field, +-- but sometimes also "error" field, hence a class other than DecodeAeson. +class DecodeOgmios o where + decodeOgmios :: Aeson -> Either OgmiosDecodeError o + +-- | Given how to parse result or error fields, +-- defines a parser of the full json2rpc response. +makeDecodeOgmios + :: forall o + . These + { parseError :: Aeson -> Either JsonDecodeError o } + { parseResult :: Aeson -> Either JsonDecodeError o } + -> Aeson + -> Either OgmiosDecodeError o +makeDecodeOgmios decoders aeson = do + json <- lmap InvalidResponse $ decodeAesonJsonRpc2Response aeson + let merr = _.parseError <$> theseLeft decoders <*> json.error + let mres = _.parseResult <$> theseRight decoders <*> json.result + case (mres /\ merr) of + -- Expected result, got it + Just (Right x) /\ _ -> pure x + -- Expected result, got it in a wrong format + Just (Left err) /\ _ -> Left $ ResultDecodingError err + -- Got an expected error + _ /\ Just (Right x) -> pure x + -- Got an unexpected error + _ -> do + err :: Maybe OgmiosError <- sequence $ + lmap InvalidResponse <<< decodeAeson <$> json.error + Left $ ErrorResponse err + +-- | Decode "result" field of ogmios response. +decodeResult + :: forall o + . (Aeson -> Either JsonDecodeError o) + -> Aeson + -> Either OgmiosDecodeError o +decodeResult decodeAeson = makeDecodeOgmios $ That { parseResult: decodeAeson } + +-- | Decode "result" field or if absent the error field of ogmios response. +decodeErrorOrResult + :: forall o + . { parseError :: (Aeson -> Either JsonDecodeError o) } + -> { parseResult :: (Aeson -> Either JsonDecodeError o) } + -> Aeson + -> Either OgmiosDecodeError o +decodeErrorOrResult err res = makeDecodeOgmios $ Both err res + +-- | Structure of all json rpc websocket responses +-- described in: https://ogmios.dev/getting-started/basics/ +type JsonRpc2Response = + { jsonrpc :: String + -- methodname is not always present if `error` is not empty + , method :: Maybe String + , result :: Maybe Aeson + , error :: Maybe Aeson + , id :: ListenerId + } + +decodeAesonJsonRpc2Response + :: Aeson -> Either JsonDecodeError JsonRpc2Response +decodeAesonJsonRpc2Response = aesonObject $ \o -> do + jsonrpc <- getField o "jsonrpc" + method <- getFieldOptional o "method" + result <- getFieldOptional o "result" + error <- getFieldOptional o "error" + id <- getField o "id" + pure + { jsonrpc + , method + , result + , error + , id + } diff --git a/src/Internal/QueryM/Pools.purs b/src/Internal/QueryM/Pools.purs index ec63b050dd..ac4162f020 100644 --- a/src/Internal/QueryM/Pools.purs +++ b/src/Internal/QueryM/Pools.purs @@ -16,9 +16,11 @@ import Cardano.Types.ScriptHash as ScriptHash import Control.Monad.Error.Class (throwError) import Ctl.Internal.Helpers (liftM) import Ctl.Internal.QueryM (QueryM) -import Ctl.Internal.QueryM.JsonRpc2 (pprintOgmiosDecodeError) import Ctl.Internal.QueryM.Ogmios as Ogmios -import Ctl.Internal.QueryM.Ogmios.Types (PoolParameters) +import Ctl.Internal.QueryM.Ogmios.Types + ( PoolParameters + , pprintOgmiosDecodeError + ) import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) import Data.ByteArray (byteArrayToHex) import Data.Either (Either(Right, Left)) diff --git a/test/Ogmios/Aeson.purs b/test/Ogmios/Aeson.purs index 059fa6d0e5..35f871d77e 100644 --- a/test/Ogmios/Aeson.purs +++ b/test/Ogmios/Aeson.purs @@ -10,19 +10,17 @@ import Aeson as Aeson import Control.Monad.Error.Class (liftEither) import Control.Monad.Trans.Class (lift) import Control.Parallel (parTraverse) -import Ctl.Internal.QueryM.JsonRpc2 - ( class DecodeOgmios - , OgmiosDecodeError(ErrorResponse) - , decodeOgmios - ) import Ctl.Internal.QueryM.Ogmios.Mempool ( HasTxR , MempoolSizeAndCapacity ) as Mempool import Ctl.Internal.QueryM.Ogmios.Types - ( OgmiosTxEvaluationR + ( class DecodeOgmios + , OgmiosDecodeError(ErrorResponse) + , OgmiosTxEvaluationR , SubmitTxR , aesonObject + , decodeOgmios ) import Ctl.Internal.QueryM.Ogmios.Types as O import Data.Array (catMaybes, groupAllBy, nubBy) diff --git a/test/Ogmios/EvaluateTx.purs b/test/Ogmios/EvaluateTx.purs index 8d4417e819..fd81e2ea16 100644 --- a/test/Ogmios/EvaluateTx.purs +++ b/test/Ogmios/EvaluateTx.purs @@ -13,11 +13,11 @@ import Cardano.Provider.TxEvaluation import Cardano.Types (BigNum) import Cardano.Types.BigNum as BigNum import Cardano.Types.RedeemerTag (RedeemerTag(Spend, Cert, Reward)) -import Ctl.Internal.QueryM.JsonRpc2 +import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosDecodeError(ResultDecodingError) + , OgmiosTxEvaluationR , decodeOgmios ) -import Ctl.Internal.QueryM.Ogmios.Types (OgmiosTxEvaluationR) import Data.Either (Either(Left, Right)) import Data.Map as Map import Data.Maybe (fromJust) diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index c9d59160b2..fe324b0bbf 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -7,7 +7,6 @@ import Prelude import Aeson (class EncodeAeson, Aeson, encodeAeson, stringifyAeson) import Control.Parallel (parTraverse) import Ctl.Internal.Helpers (logString) -import Ctl.Internal.QueryM.JsonRpc2 (class DecodeOgmios, JsonRpc2Call) import Ctl.Internal.QueryM.Ogmios.Dispatcher ( WebsocketDispatch , mkWebsocketDispatch @@ -20,6 +19,7 @@ import Ctl.Internal.QueryM.Ogmios.JsWebSocket , _wsClose , _wsSend ) +import Ctl.Internal.QueryM.Ogmios.JsonRpc2 (JsonRpc2Call) import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , WebSocket(WebSocket) @@ -28,6 +28,7 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , mkOgmiosCallType , mkRequestAff ) +import Ctl.Internal.QueryM.Ogmios.Types (class DecodeOgmios) import Ctl.Internal.ServerConfig ( ServerConfig , defaultOgmiosWsConfig From af6d6f5a4ddb8ccced6320815e5fae44f0edc01e Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 14:36:09 -0300 Subject: [PATCH 10/27] Rename `Ogmios.Queries` to `Ogmios.QueryEnv` --- src/Internal/Contract/Monad.purs | 2 +- src/Internal/QueryM.purs | 2 +- src/Internal/QueryM/Ogmios/{Queries.purs => QueryEnv.purs} | 2 +- src/Internal/Test/E2E/Feedback/Browser.purs | 2 +- src/Internal/Test/E2E/Feedback/Node.purs | 2 +- src/Internal/Test/E2E/Route.purs | 2 +- src/Internal/Test/E2E/Runner.purs | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) rename src/Internal/QueryM/Ogmios/{Queries.purs => QueryEnv.purs} (98%) diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index 226ff39f3c..5d537f78f2 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -67,7 +67,7 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , mkOgmiosWebSocketAff , underlyingWebSocket ) -import Ctl.Internal.QueryM.Ogmios.Queries (QueryEnv) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryEnv) import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosDecodeError , pprintOgmiosDecodeError diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index f882c8902c..e8e9590917 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -26,7 +26,7 @@ import Control.Monad.Rec.Class (class MonadRec) import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) import Ctl.Internal.Helpers (logWithLevel) -import Ctl.Internal.QueryM.Ogmios.Queries (QueryEnv) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryEnv) import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right)) import Data.Maybe (fromMaybe) diff --git a/src/Internal/QueryM/Ogmios/Queries.purs b/src/Internal/QueryM/Ogmios/QueryEnv.purs similarity index 98% rename from src/Internal/QueryM/Ogmios/Queries.purs rename to src/Internal/QueryM/Ogmios/QueryEnv.purs index bf5654d006..9fa4c76c44 100644 --- a/src/Internal/QueryM/Ogmios/Queries.purs +++ b/src/Internal/QueryM/Ogmios/QueryEnv.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.Ogmios.Queries +module Ctl.Internal.QueryM.Ogmios.QueryEnv ( module ExportDispatcher , module ExportServerConfig , ClusterSetup diff --git a/src/Internal/Test/E2E/Feedback/Browser.purs b/src/Internal/Test/E2E/Feedback/Browser.purs index 1f242deee7..d4f3dd43d6 100644 --- a/src/Internal/Test/E2E/Feedback/Browser.purs +++ b/src/Internal/Test/E2E/Feedback/Browser.purs @@ -13,7 +13,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, jsonToAeson, stringifyAeson) import Ctl.Internal.FfiHelpers (MaybeFfiHelper, maybeFfiHelper) import Ctl.Internal.Helpers (liftedM) -import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent) import Data.Argonaut (Json) import Data.Either (hush) diff --git a/src/Internal/Test/E2E/Feedback/Node.purs b/src/Internal/Test/E2E/Feedback/Node.purs index ab9b0cef3f..718dcbda8e 100644 --- a/src/Internal/Test/E2E/Feedback/Node.purs +++ b/src/Internal/Test/E2E/Feedback/Node.purs @@ -12,7 +12,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, parseJsonStringToAeson, stringifyAeson) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent(Failure, Success)) import Data.Array as Array import Data.Either (Either(Left), hush, note) diff --git a/src/Internal/Test/E2E/Route.purs b/src/Internal/Test/E2E/Route.purs index fd71ab2d41..7fcd27c3e8 100644 --- a/src/Internal/Test/E2E/Route.purs +++ b/src/Internal/Test/E2E/Route.purs @@ -25,7 +25,7 @@ import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftMaybe) import Ctl.Internal.Contract.ProviderBackend (mkCtlBackendParams) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback.Browser (getClusterSetupRepeatedly) import Ctl.Internal.Test.E2E.Feedback.Hooks (addE2EFeedbackHooks) import Ctl.Internal.Wallet.Spec (WalletSpec(ConnectToGenericCip30)) diff --git a/src/Internal/Test/E2E/Runner.purs b/src/Internal/Test/E2E/Runner.purs index 75d9703fdc..f1901afada 100644 --- a/src/Internal/Test/E2E/Runner.purs +++ b/src/Internal/Test/E2E/Runner.purs @@ -24,7 +24,7 @@ import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Contract.Hooks (emptyHooks) import Ctl.Internal.Contract.ProviderBackend (ProviderBackend(CtlBackend)) import Ctl.Internal.Helpers (liftedM, unsafeFromJust, (<>)) -import Ctl.Internal.QueryM.Ogmios.Queries (ClusterSetup) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) import Ctl.Internal.Test.E2E.Browser (withBrowser) import Ctl.Internal.Test.E2E.Feedback ( BrowserEvent(ConfirmAccess, Sign, Success, Failure) From fb552518328e3d64ed5aeadc824bbaf7c6037aab Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 17:16:51 -0300 Subject: [PATCH 11/27] Remove `uniqueId` and `ServerConfig` dependencies from Ogmios.Mempool --- src/Contract/Backend/Ogmios/Mempool.purs | 11 +- src/Internal/Contract/Monad.purs | 10 +- src/Internal/QueryM/Ogmios/Dispatcher.purs | 4 +- src/Internal/QueryM/Ogmios/JsonRpc2.purs | 17 +-- src/Internal/QueryM/Ogmios/Mempool.purs | 124 ++++++++++++--------- src/Internal/QueryM/Ogmios/QueryEnv.purs | 25 +---- src/Internal/QueryM/Ogmios/Types.purs | 3 +- src/Internal/ServerConfig.purs | 3 +- test/Ogmios/GenerateFixtures.purs | 9 +- 9 files changed, 103 insertions(+), 103 deletions(-) diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index eede83e532..e3623cb81b 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -41,6 +41,7 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , MempoolSnapshotAcquired , MempoolTransaction(MempoolTransaction) ) as Ogmios +import Ctl.Internal.QueryM.UniqueId (uniqueId) import Data.Array as Array import Data.ByteArray (hexToByteArray) import Data.List (List(Cons)) @@ -116,7 +117,7 @@ acquireMempoolSnapshotFetch :: QueryM Ogmios.MempoolSnapshotAcquired acquireMempoolSnapshotFetch = mkOgmiosRequest - acquireMempoolSnapshotCall + (acquireMempoolSnapshotCall uniqueId) _.acquireMempool unit @@ -126,7 +127,7 @@ mempoolSnapshotHasTxFetch -> QueryM Boolean mempoolSnapshotHasTxFetch ms txh = unwrap <$> mkOgmiosRequest - (mempoolSnapshotHasTxCall ms) + (mempoolSnapshotHasTxCall uniqueId ms) _.mempoolHasTx txh @@ -135,7 +136,7 @@ mempoolSnapshotSizeAndCapacityFetch -> QueryM Ogmios.MempoolSizeAndCapacity mempoolSnapshotSizeAndCapacityFetch ms = mkOgmiosRequest - (mempoolSnapshotSizeAndCapacityCall ms) + (mempoolSnapshotSizeAndCapacityCall uniqueId ms) _.mempoolSizeAndCapacity unit @@ -144,7 +145,7 @@ releaseMempoolFetch -> QueryM Unit releaseMempoolFetch ms = unit <$ mkOgmiosRequest - (releaseMempoolCall ms) + (releaseMempoolCall uniqueId ms) _.releaseMempool unit @@ -153,7 +154,7 @@ mempoolSnapshotNextTxFetch -> QueryM (Maybe Ogmios.MempoolTransaction) mempoolSnapshotNextTxFetch ms = unwrap <$> mkOgmiosRequest - (mempoolSnapshotNextTxCall ms) + (mempoolSnapshotNextTxCall uniqueId ms) _.mempoolNextTx unit diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index 5d537f78f2..917add51e3 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -57,10 +57,7 @@ import Ctl.Internal.Helpers (filterMapWithKeyM, liftM, logWithLevel) import Ctl.Internal.Logging (Logger, mkLogger, setupLogs) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) -import Ctl.Internal.QueryM.Ogmios - ( getProtocolParameters - , getSystemStartTime - ) +import Ctl.Internal.QueryM.Ogmios (getProtocolParameters, getSystemStartTime) import Ctl.Internal.QueryM.Ogmios.JsWebSocket (_wsClose, _wsFinalize) import Ctl.Internal.QueryM.Ogmios.Mempool ( WebSocket @@ -72,6 +69,8 @@ import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosDecodeError , pprintOgmiosDecodeError ) +import Ctl.Internal.QueryM.UniqueId (uniqueId) +import Ctl.Internal.ServerConfig (mkWsUrl) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM @@ -277,7 +276,8 @@ buildBackend logger = case _ of buildCtlBackend :: CtlBackendParams -> Aff CtlBackend buildCtlBackend { ogmiosConfig, kupoConfig } = do let isTxConfirmed = map isRight <<< isTxConfirmedAff kupoConfig - ogmiosWs <- mkOgmiosWebSocketAff isTxConfirmed logger ogmiosConfig + ogmiosWs <- mkOgmiosWebSocketAff uniqueId isTxConfirmed logger + (mkWsUrl ogmiosConfig) pure { ogmios: { config: ogmiosConfig diff --git a/src/Internal/QueryM/Ogmios/Dispatcher.purs b/src/Internal/QueryM/Ogmios/Dispatcher.purs index b0bf90c0d2..6a2a809188 100644 --- a/src/Internal/QueryM/Ogmios/Dispatcher.purs +++ b/src/Internal/QueryM/Ogmios/Dispatcher.purs @@ -10,6 +10,7 @@ module Ctl.Internal.QueryM.Ogmios.Dispatcher , mkWebsocketDispatch , newDispatcher , newPendingRequests + , ListenerId ) where import Prelude @@ -17,7 +18,6 @@ import Prelude import Aeson (Aeson, JsonDecodeError, stringifyAeson) import Cardano.Types.TransactionHash (TransactionHash) import Ctl.Internal.QueryM.Ogmios.JsonRpc2 (parseJsonRpc2ResponseId) -import Ctl.Internal.QueryM.UniqueId (ListenerId) import Data.Either (Either(Left, Right)) import Data.Map (Map) import Data.Map (empty, lookup) as Map @@ -28,6 +28,8 @@ import Effect.Exception (Error, error) import Effect.Ref (Ref) import Effect.Ref (new, read) as Ref +type ListenerId = String + data DispatchError = JsonError JsonDecodeError -- Server response has been parsed succesfully, but it contains error diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/JsonRpc2.purs index 76b55ca183..24f64a4e8d 100644 --- a/src/Internal/QueryM/Ogmios/JsonRpc2.purs +++ b/src/Internal/QueryM/Ogmios/JsonRpc2.purs @@ -18,7 +18,6 @@ import Aeson , encodeAeson , getField ) -import Ctl.Internal.QueryM.UniqueId (ListenerId, uniqueId) import Data.Either (Either(Left)) import Effect (Effect) import Foreign.Object (Object) @@ -30,18 +29,19 @@ type JsonRpc2Request (a :: Type) = { jsonrpc :: String , method :: String , params :: a - , id :: ListenerId + , id :: String } -- | Convenience helper function for creating `JsonRpc2Request a` objects mkJsonRpc2Request :: forall (a :: Type) - . { jsonrpc :: String } + . (String -> Effect String) + -> { jsonrpc :: String } -> { method :: String , params :: a } -> Effect (JsonRpc2Request a) -mkJsonRpc2Request service method = do +mkJsonRpc2Request uniqueId service method = do id <- uniqueId $ method.method <> "-" pure $ Record.merge { id } @@ -57,11 +57,12 @@ newtype JsonRpc2Call (i :: Type) (o :: Type) = JsonRpc2Call mkCallType :: forall (a :: Type) (i :: Type) (o :: Type) . EncodeAeson (JsonRpc2Request a) - => { jsonrpc :: String } + => (String -> Effect String) + -> { jsonrpc :: String } -> { method :: String, params :: i -> a } -> JsonRpc2Call i o -mkCallType service { method, params } = JsonRpc2Call \i -> do - req <- mkJsonRpc2Request service { method, params: params i } +mkCallType uniqueId service { method, params } = JsonRpc2Call \i -> do + req <- mkJsonRpc2Request uniqueId service { method, params: params i } pure { body: encodeAeson req, id: req.id } -- | Create a JsonRpc2 request body and id @@ -75,7 +76,7 @@ buildRequest (JsonRpc2Call c) = c -- | Parse just ID from the response parseJsonRpc2ResponseId :: Aeson - -> Either JsonDecodeError ListenerId + -> Either JsonDecodeError String parseJsonRpc2ResponseId = aesonObject $ flip getField "id" diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index fc195c111d..a7bba056a4 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -17,6 +17,7 @@ module Ctl.Internal.QueryM.Ogmios.Mempool , releaseMempoolCall , ListenerSet , OgmiosListeners + , ListenerId , mkOgmiosCallType , OgmiosWebSocket , SubmitTxListenerSet @@ -29,6 +30,7 @@ module Ctl.Internal.QueryM.Ogmios.Mempool , mkRequestAff , underlyingWebSocket , mkOgmiosWebSocketLens + , Logger , mkSubmitTxListenerSet , MkServiceWebSocketLens ) where @@ -53,7 +55,6 @@ import Cardano.Types.Slot (Slot) import Cardano.Types.TransactionHash (TransactionHash) import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftEither, throwError) -import Ctl.Internal.Logging (Logger) import Ctl.Internal.QueryM.Ogmios.Dispatcher ( DispatchError(JsonError) , Dispatcher @@ -106,8 +107,6 @@ import Ctl.Internal.QueryM.Ogmios.Types , ogmiosDecodeErrorToError , submitSuccessPartialResp ) -import Ctl.Internal.QueryM.UniqueId (ListenerId) -import Ctl.Internal.ServerConfig (ServerConfig, mkWsUrl) import Data.Argonaut.Encode.Encoders as Argonaut import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right), either, isRight) @@ -127,98 +126,112 @@ import Effect.Class (liftEffect) import Effect.Exception (Error, error) import Effect.Ref as Ref +type ListenerId = String +type MkUniqueId = (String -> Effect String) + +type Logger = LogLevel -> String -> Effect Unit + -------------------------------------------------------------------------------- -- Ogmios Local Tx Monitor Protocol -------------------------------------------------------------------------------- acquireMempoolSnapshotAff - :: OgmiosWebSocket -> Logger -> Aff MempoolSnapshotAcquired -acquireMempoolSnapshotAff ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger acquireMempoolSnapshotCall + :: MkUniqueId -> OgmiosWebSocket -> Logger -> Aff MempoolSnapshotAcquired +acquireMempoolSnapshotAff u ogmiosWs logger = + mkOgmiosRequestAff ogmiosWs logger (acquireMempoolSnapshotCall u) _.acquireMempool unit mempoolSnapshotHasTxAff - :: OgmiosWebSocket + :: MkUniqueId + -> OgmiosWebSocket -> Logger -> MempoolSnapshotAcquired -> TransactionHash -> Aff Boolean -mempoolSnapshotHasTxAff ogmiosWs logger ms txh = +mempoolSnapshotHasTxAff u ogmiosWs logger ms txh = unwrap <$> mkOgmiosRequestAff ogmiosWs logger - (mempoolSnapshotHasTxCall ms) + (mempoolSnapshotHasTxCall u ms) _.mempoolHasTx txh mempoolSnapshotSizeAndCapacityAff - :: OgmiosWebSocket + :: MkUniqueId + -> OgmiosWebSocket -> Logger -> MempoolSnapshotAcquired -> Aff MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityAff ogmiosWs logger ms = +mempoolSnapshotSizeAndCapacityAff u ogmiosWs logger ms = mkOgmiosRequestAff ogmiosWs logger - (mempoolSnapshotSizeAndCapacityCall ms) + (mempoolSnapshotSizeAndCapacityCall u ms) _.mempoolSizeAndCapacity -- todo: typo unit releaseMempoolAff - :: OgmiosWebSocket + :: MkUniqueId + -> OgmiosWebSocket -> Logger -> MempoolSnapshotAcquired -> Aff ReleasedMempool -releaseMempoolAff ogmiosWs logger ms = - mkOgmiosRequestAff ogmiosWs logger (releaseMempoolCall ms) +releaseMempoolAff u ogmiosWs logger ms = + mkOgmiosRequestAff ogmiosWs logger (releaseMempoolCall u ms) _.releaseMempool unit mempoolSnapshotNextTxAff - :: OgmiosWebSocket + :: MkUniqueId + -> OgmiosWebSocket -> Logger -> MempoolSnapshotAcquired -> Aff (Maybe MempoolTransaction) -mempoolSnapshotNextTxAff ogmiosWs logger ms = unwrap <$> - mkOgmiosRequestAff ogmiosWs logger (mempoolSnapshotNextTxCall ms) +mempoolSnapshotNextTxAff u ogmiosWs logger ms = unwrap <$> + mkOgmiosRequestAff ogmiosWs logger (mempoolSnapshotNextTxCall u ms) _.mempoolNextTx unit -acquireMempoolSnapshotCall :: JsonRpc2Call Unit MempoolSnapshotAcquired -acquireMempoolSnapshotCall = - mkOgmiosCallTypeNoArgs "acquireMempool" +acquireMempoolSnapshotCall + :: MkUniqueId -> JsonRpc2Call Unit MempoolSnapshotAcquired +acquireMempoolSnapshotCall u = + mkOgmiosCallTypeNoArgs u "acquireMempool" mempoolSnapshotHasTxCall - :: MempoolSnapshotAcquired + :: MkUniqueId + -> MempoolSnapshotAcquired -> JsonRpc2Call TransactionHash HasTxR -mempoolSnapshotHasTxCall _ = mkOgmiosCallType +mempoolSnapshotHasTxCall u _ = mkOgmiosCallType u { method: "hasTransaction" , params: { id: _ } } mempoolSnapshotNextTxCall - :: MempoolSnapshotAcquired + :: MkUniqueId + -> MempoolSnapshotAcquired -> JsonRpc2Call Unit MaybeMempoolTransaction -mempoolSnapshotNextTxCall _ = mkOgmiosCallType +mempoolSnapshotNextTxCall u _ = mkOgmiosCallType u { method: "nextTransaction" , params: const { fields: "all" } } mempoolSnapshotSizeAndCapacityCall - :: MempoolSnapshotAcquired + :: MkUniqueId + -> MempoolSnapshotAcquired -> JsonRpc2Call Unit MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityCall _ = - mkOgmiosCallTypeNoArgs "sizeOfMempool" +mempoolSnapshotSizeAndCapacityCall u _ = + mkOgmiosCallTypeNoArgs u "sizeOfMempool" releaseMempoolCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool -releaseMempoolCall _ = - mkOgmiosCallTypeNoArgs "releaseMempool" + :: MkUniqueId -> MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool +releaseMempoolCall u _ = + mkOgmiosCallTypeNoArgs u "releaseMempool" withMempoolSnapshot - :: OgmiosWebSocket + :: MkUniqueId + -> OgmiosWebSocket -> Logger -> (Maybe MempoolSnapshotAcquired -> Aff Unit) -> Effect Unit -withMempoolSnapshot ogmiosWs logger cont = - flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of +withMempoolSnapshot u ogmiosWs logger cont = + flip runAff_ (acquireMempoolSnapshotAff u ogmiosWs logger) $ case _ of Left err -> do logger Error $ "Failed to acquire a mempool snapshot: Error: " <> show err @@ -231,18 +244,23 @@ withMempoolSnapshot ogmiosWs logger cont = -------------------------------------------------------------------------------- mkOgmiosCallTypeNoArgs - :: forall (o :: Type). DecodeOgmios o => String -> JsonRpc2Call Unit o -mkOgmiosCallTypeNoArgs method = - mkOgmiosCallType { method, params: const {} } + :: forall (o :: Type) + . DecodeOgmios o + => MkUniqueId + -> String + -> JsonRpc2Call Unit o +mkOgmiosCallTypeNoArgs u method = + mkOgmiosCallType u { method, params: const {} } mkOgmiosCallType :: forall (a :: Type) (i :: Type) (o :: Type) . EncodeAeson (JsonRpc2Request a) => DecodeOgmios o - => { method :: String, params :: i -> a } + => MkUniqueId + -> { method :: String, params :: i -> a } -> JsonRpc2Call i o -mkOgmiosCallType = - mkCallType { jsonrpc: "2.0" } +mkOgmiosCallType u = + mkCallType u { jsonrpc: "2.0" } -------------------------------------------------------------------------------- -- WebSocket @@ -273,13 +291,14 @@ listeners (WebSocket _ ls) = ls type IsTxConfirmed = TransactionHash -> Aff Boolean mkOgmiosWebSocketAff - :: IsTxConfirmed + :: MkUniqueId + -> IsTxConfirmed -> Logger - -> ServerConfig + -> String -> Aff OgmiosWebSocket -mkOgmiosWebSocketAff isTxConfirmed logger serverConfig = do - lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed - makeAff $ mkServiceWebSocket lens (mkWsUrl serverConfig) +mkOgmiosWebSocketAff u isTxConfirmed logger serverUrl = do + lens <- liftEffect $ mkOgmiosWebSocketLens u logger isTxConfirmed + makeAff $ mkServiceWebSocket lens serverUrl mkServiceWebSocket :: forall (listeners :: Type) @@ -336,7 +355,8 @@ mkServiceWebSocket lens url continue = do -- | been added to the mempool or has been included in a block before retrying -- | the request. resendPendingSubmitRequests - :: OgmiosWebSocket + :: MkUniqueId + -> OgmiosWebSocket -> IsTxConfirmed -> Logger -> (RequestBody -> Effect Unit) @@ -344,6 +364,7 @@ resendPendingSubmitRequests -> PendingSubmitTxRequests -> Effect Unit resendPendingSubmitRequests + u ogmiosWs isTxConfirmed logger @@ -354,7 +375,7 @@ resendPendingSubmitRequests unless (Map.isEmpty submitTxPendingRequests) do -- Acquiring a mempool snapshot should never fail and, -- after ws reconnection, should be instantaneous. - withMempoolSnapshot ogmiosWs logger case _ of + withMempoolSnapshot u ogmiosWs logger case _ of Nothing -> liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests Just ms -> do @@ -378,7 +399,7 @@ resendPendingSubmitRequests -> Aff Unit handlePendingSubmitRequest ms listenerId requestBody txHash = do -- Check if the transaction was added to the mempool: - txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash + txInMempool <- mempoolSnapshotHasTxAff u ogmiosWs logger ms txHash log "Tx in the mempool" txInMempool txHash retrySubmitTx <- if txInMempool then pure false @@ -414,10 +435,11 @@ type MkServiceWebSocketLens (listeners :: Type) = } mkOgmiosWebSocketLens - :: Logger + :: MkUniqueId + -> Logger -> IsTxConfirmed -> Effect (MkServiceWebSocketLens OgmiosListeners) -mkOgmiosWebSocketLens logger isTxConfirmed = do +mkOgmiosWebSocketLens u logger isTxConfirmed = do dispatcher <- newDispatcher pendingRequests <- newPendingRequests pendingSubmitTxRequests <- newPendingRequests @@ -459,7 +481,7 @@ mkOgmiosWebSocketLens logger isTxConfirmed = do resendPendingRequests ws = do let sendRequest = _wsSend ws (logger Debug) Ref.read pendingRequests >>= traverse_ sendRequest - resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed + resendPendingSubmitRequests u (ogmiosWebSocket ws) isTxConfirmed logger sendRequest dispatcher diff --git a/src/Internal/QueryM/Ogmios/QueryEnv.purs b/src/Internal/QueryM/Ogmios/QueryEnv.purs index 9fa4c76c44..ddaee3d462 100644 --- a/src/Internal/QueryM/Ogmios/QueryEnv.purs +++ b/src/Internal/QueryM/Ogmios/QueryEnv.purs @@ -1,7 +1,5 @@ module Ctl.Internal.QueryM.Ogmios.QueryEnv - ( module ExportDispatcher - , module ExportServerConfig - , ClusterSetup + ( ClusterSetup , QueryConfig , QueryEnv , QueryRuntime @@ -10,28 +8,7 @@ module Ctl.Internal.QueryM.Ogmios.QueryEnv import Prelude import Cardano.Wallet.Key (PrivatePaymentKey, PrivateStakeKey) -import Ctl.Internal.QueryM.Ogmios.Dispatcher - ( DispatchError(JsonError, FaultError, ListenerCancelled) - , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests - , RequestBody - , WebsocketDispatch - , dispatchErrorToError - , mkWebsocketDispatch - , newDispatcher - , newPendingRequests - ) as ExportDispatcher import Ctl.Internal.QueryM.Ogmios.Mempool (OgmiosWebSocket) -import Ctl.Internal.ServerConfig - ( Host - , ServerConfig - , defaultOgmiosWsConfig - , mkHttpUrl - , mkServerUrl - , mkWsUrl - ) as ExportServerConfig import Ctl.Internal.ServerConfig (ServerConfig) import Data.Log.Level (LogLevel) import Data.Log.Message (Message) diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index fc680fd2ec..de24b25023 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -139,7 +139,6 @@ import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) import Control.Alt ((<|>)) import Control.Alternative (guard) import Ctl.Internal.Helpers (encodeMap, showWithParens) -import Ctl.Internal.QueryM.UniqueId (ListenerId) import Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) ) @@ -1126,7 +1125,7 @@ type JsonRpc2Response = , method :: Maybe String , result :: Maybe Aeson , error :: Maybe Aeson - , id :: ListenerId + , id :: String } decodeAesonJsonRpc2Response diff --git a/src/Internal/ServerConfig.purs b/src/Internal/ServerConfig.purs index 47ebef8173..f449f62139 100644 --- a/src/Internal/ServerConfig.purs +++ b/src/Internal/ServerConfig.purs @@ -16,7 +16,6 @@ module Ctl.Internal.ServerConfig import Prelude import Ctl.Internal.Helpers ((<>)) -import Ctl.Internal.QueryM.Ogmios.JsWebSocket (Url) import Data.Maybe (Maybe(Just, Nothing), fromMaybe) import Data.UInt (UInt) import Data.UInt as UInt @@ -86,6 +85,8 @@ blockfrostSelfHostedServerConfig = , path: Just "" } +type Url = String + mkHttpUrl :: ServerConfig -> Url mkHttpUrl = mkServerUrl "http" diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index fe324b0bbf..8c3740b15e 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -29,11 +29,8 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , mkRequestAff ) import Ctl.Internal.QueryM.Ogmios.Types (class DecodeOgmios) -import Ctl.Internal.ServerConfig - ( ServerConfig - , defaultOgmiosWsConfig - , mkWsUrl - ) +import Ctl.Internal.QueryM.UniqueId (uniqueId) +import Ctl.Internal.ServerConfig (ServerConfig, defaultOgmiosWsConfig, mkWsUrl) import Data.Either (Either(Left, Right)) import Data.Log.Level (LogLevel(Trace, Debug)) import Data.Map as Map @@ -107,7 +104,7 @@ instance DecodeOgmios AesonResponse where mkQueryWithArgs' :: forall a. EncodeAeson a => String -> a -> Query mkQueryWithArgs' method a = Query - (mkOgmiosCallType { method, params: identity }) + (mkOgmiosCallType uniqueId { method, params: identity }) (sanitiseMethod method) (encodeAeson a) From ea5432071178d85317dd86ca7f1db77ef11a1216 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Wed, 5 Feb 2025 17:31:59 -0300 Subject: [PATCH 12/27] Extract common configuration out of `Ogmios.Mempool` --- src/Internal/Contract/Monad.purs | 3 +- src/Internal/QueryM.purs | 44 +++++++++++++++++++- src/Internal/QueryM/Ogmios/QueryEnv.purs | 46 +-------------------- src/Internal/Test/E2E/Feedback/Browser.purs | 2 +- src/Internal/Test/E2E/Feedback/Node.purs | 2 +- src/Internal/Test/E2E/Route.purs | 2 +- src/Internal/Test/E2E/Runner.purs | 2 +- 7 files changed, 48 insertions(+), 53 deletions(-) diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index 917add51e3..d8c3699a2a 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -55,7 +55,7 @@ import Ctl.Internal.Contract.ProviderBackend ) import Ctl.Internal.Helpers (filterMapWithKeyM, liftM, logWithLevel) import Ctl.Internal.Logging (Logger, mkLogger, setupLogs) -import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM (QueryEnv, QueryM) import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) import Ctl.Internal.QueryM.Ogmios (getProtocolParameters, getSystemStartTime) import Ctl.Internal.QueryM.Ogmios.JsWebSocket (_wsClose, _wsFinalize) @@ -64,7 +64,6 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , mkOgmiosWebSocketAff , underlyingWebSocket ) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryEnv) import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosDecodeError , pprintOgmiosDecodeError diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index e8e9590917..67b8590429 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -2,6 +2,9 @@ -- | This module defines an Aff interface for backend queries. module Ctl.Internal.QueryM ( QueryM + , QueryEnv + , QueryConfig + , ClusterSetup , ParQueryM , QueryMT(QueryMT) , handleAffjaxResponse @@ -16,6 +19,7 @@ import Cardano.Provider.Error ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) , ServiceError(ServiceOtherError) ) +import Cardano.Wallet.Key (PrivatePaymentKey, PrivateStakeKey) import Control.Alt (class Alt) import Control.Alternative (class Alternative) import Control.Monad.Error.Class (class MonadError, class MonadThrow) @@ -26,16 +30,52 @@ import Control.Monad.Rec.Class (class MonadRec) import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) import Ctl.Internal.Helpers (logWithLevel) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryEnv) +import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryRuntime) +import Ctl.Internal.ServerConfig (ServerConfig) import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right)) -import Data.Maybe (fromMaybe) +import Data.Log.Level (LogLevel) +import Data.Log.Message (Message) +import Data.Maybe (Maybe, fromMaybe) import Data.Newtype (class Newtype, unwrap, wrap) import Effect.Aff (Aff, ParAff) import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Class (class MonadEffect) import Effect.Exception (Error) +-- | Cluster setup contains everything that is needed to run a `Contract` on +-- | a local cluster: paramters to connect to the services and private keys +-- | that are pre-funded with Ada on that cluster +type ClusterSetup = + { ogmiosConfig :: ServerConfig + , kupoConfig :: ServerConfig + , keys :: + { payment :: PrivatePaymentKey + , stake :: Maybe PrivateStakeKey + } + } + +-- | `QueryConfig` contains a complete specification on how to initialize a +-- | `QueryM` environment. +-- | It includes: +-- | - server parameters for all the services +-- | - network ID +-- | - logging level +-- | - optional custom logger +type QueryConfig = + { ogmiosConfig :: ServerConfig + , kupoConfig :: ServerConfig + , logLevel :: LogLevel + , customLogger :: Maybe (LogLevel -> Message -> Aff Unit) + , suppressLogs :: Boolean + } + +-- | `QueryEnv` contains everything needed for `QueryM` to run. +type QueryEnv = + { config :: QueryConfig + , runtime :: QueryRuntime + } + type QueryM = QueryMT Aff type ParQueryM = QueryMT ParAff diff --git a/src/Internal/QueryM/Ogmios/QueryEnv.purs b/src/Internal/QueryM/Ogmios/QueryEnv.purs index ddaee3d462..33b6799530 100644 --- a/src/Internal/QueryM/Ogmios/QueryEnv.purs +++ b/src/Internal/QueryM/Ogmios/QueryEnv.purs @@ -1,46 +1,8 @@ module Ctl.Internal.QueryM.Ogmios.QueryEnv - ( ClusterSetup - , QueryConfig - , QueryEnv - , QueryRuntime + ( QueryRuntime ) where -import Prelude - -import Cardano.Wallet.Key (PrivatePaymentKey, PrivateStakeKey) import Ctl.Internal.QueryM.Ogmios.Mempool (OgmiosWebSocket) -import Ctl.Internal.ServerConfig (ServerConfig) -import Data.Log.Level (LogLevel) -import Data.Log.Message (Message) -import Data.Maybe (Maybe) -import Effect.Aff (Aff) - --- | Cluster setup contains everything that is needed to run a `Contract` on --- | a local cluster: paramters to connect to the services and private keys --- | that are pre-funded with Ada on that cluster -type ClusterSetup = - { ogmiosConfig :: ServerConfig - , kupoConfig :: ServerConfig - , keys :: - { payment :: PrivatePaymentKey - , stake :: Maybe PrivateStakeKey - } - } - --- | `QueryConfig` contains a complete specification on how to initialize a --- | `QueryM` environment. --- | It includes: --- | - server parameters for all the services --- | - network ID --- | - logging level --- | - optional custom logger -type QueryConfig = - { ogmiosConfig :: ServerConfig - , kupoConfig :: ServerConfig - , logLevel :: LogLevel - , customLogger :: Maybe (LogLevel -> Message -> Aff Unit) - , suppressLogs :: Boolean - } -- | Reusable part of `QueryRuntime` that can be shared between many `QueryM` -- | instances running in parallel. @@ -51,9 +13,3 @@ type QueryRuntime = { ogmiosWs :: OgmiosWebSocket } --- | `QueryEnv` contains everything needed for `QueryM` to run. -type QueryEnv = - { config :: QueryConfig - , runtime :: QueryRuntime - } - diff --git a/src/Internal/Test/E2E/Feedback/Browser.purs b/src/Internal/Test/E2E/Feedback/Browser.purs index d4f3dd43d6..6b27bb98d2 100644 --- a/src/Internal/Test/E2E/Feedback/Browser.purs +++ b/src/Internal/Test/E2E/Feedback/Browser.purs @@ -13,7 +13,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, jsonToAeson, stringifyAeson) import Ctl.Internal.FfiHelpers (MaybeFfiHelper, maybeFfiHelper) import Ctl.Internal.Helpers (liftedM) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) +import Ctl.Internal.QueryM (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent) import Data.Argonaut (Json) import Data.Either (hush) diff --git a/src/Internal/Test/E2E/Feedback/Node.purs b/src/Internal/Test/E2E/Feedback/Node.purs index 718dcbda8e..e95eed1516 100644 --- a/src/Internal/Test/E2E/Feedback/Node.purs +++ b/src/Internal/Test/E2E/Feedback/Node.purs @@ -12,7 +12,7 @@ import Prelude import Aeson (decodeAeson, encodeAeson, parseJsonStringToAeson, stringifyAeson) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) +import Ctl.Internal.QueryM (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback (BrowserEvent(Failure, Success)) import Data.Array as Array import Data.Either (Either(Left), hush, note) diff --git a/src/Internal/Test/E2E/Route.purs b/src/Internal/Test/E2E/Route.purs index 7fcd27c3e8..7988505105 100644 --- a/src/Internal/Test/E2E/Route.purs +++ b/src/Internal/Test/E2E/Route.purs @@ -25,7 +25,7 @@ import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftMaybe) import Ctl.Internal.Contract.ProviderBackend (mkCtlBackendParams) import Ctl.Internal.Helpers (liftEither) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) +import Ctl.Internal.QueryM (ClusterSetup) import Ctl.Internal.Test.E2E.Feedback.Browser (getClusterSetupRepeatedly) import Ctl.Internal.Test.E2E.Feedback.Hooks (addE2EFeedbackHooks) import Ctl.Internal.Wallet.Spec (WalletSpec(ConnectToGenericCip30)) diff --git a/src/Internal/Test/E2E/Runner.purs b/src/Internal/Test/E2E/Runner.purs index f1901afada..81012a63fe 100644 --- a/src/Internal/Test/E2E/Runner.purs +++ b/src/Internal/Test/E2E/Runner.purs @@ -24,7 +24,7 @@ import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.Contract.Hooks (emptyHooks) import Ctl.Internal.Contract.ProviderBackend (ProviderBackend(CtlBackend)) import Ctl.Internal.Helpers (liftedM, unsafeFromJust, (<>)) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (ClusterSetup) +import Ctl.Internal.QueryM (ClusterSetup) import Ctl.Internal.Test.E2E.Browser (withBrowser) import Ctl.Internal.Test.E2E.Feedback ( BrowserEvent(ConfirmAccess, Sign, Success, Failure) From 2dcaa81f270cf5efc6b94f69be062accb755efed Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Thu, 6 Feb 2025 16:39:13 -0300 Subject: [PATCH 13/27] Remove unused exports --- src/Internal/QueryM/Ogmios/Mempool.purs | 105 +----------------------- 1 file changed, 2 insertions(+), 103 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index a7bba056a4..5450d0241c 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -5,11 +5,6 @@ module Ctl.Internal.QueryM.Ogmios.Mempool , MempoolTransaction(MempoolTransaction) , HasTxR(HasTxR) , MaybeMempoolTransaction(MaybeMempoolTransaction) - , acquireMempoolSnapshotAff - , mempoolSnapshotHasTxAff - , mempoolSnapshotNextTxAff - , mempoolSnapshotSizeAndCapacityAff - , releaseMempoolAff , acquireMempoolSnapshotCall , mempoolSnapshotHasTxCall , mempoolSnapshotNextTxCall @@ -20,19 +15,13 @@ module Ctl.Internal.QueryM.Ogmios.Mempool , ListenerId , mkOgmiosCallType , OgmiosWebSocket - , SubmitTxListenerSet , WebSocket(WebSocket) , listeners , mkListenerSet , defaultMessageListener - , mkOgmiosRequestAff , mkOgmiosWebSocketAff , mkRequestAff , underlyingWebSocket - , mkOgmiosWebSocketLens - , Logger - , mkSubmitTxListenerSet - , MkServiceWebSocketLens ) where import Prelude @@ -50,7 +39,6 @@ import Aeson , (.:) ) import Cardano.Provider.TxEvaluation (OgmiosTxId) -import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.Slot (Slot) import Cardano.Types.TransactionHash (TransactionHash) import Control.Alt ((<|>)) @@ -87,18 +75,7 @@ import Ctl.Internal.QueryM.Ogmios.JsonRpc2 import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios - , AdditionalUtxoSet - , ChainTipQR - , CurrentEpoch - , DelegationsAndRewardsR , OgmiosDecodeError - , OgmiosEraSummaries - , OgmiosProtocolParameters - , OgmiosSystemStart - , OgmiosTxEvaluationR - , PoolParametersR - , StakePoolsQueryArgument - , SubmitTxR , aesonNull , aesonObject , aesonString @@ -155,40 +132,6 @@ mempoolSnapshotHasTxAff u ogmiosWs logger ms txh = _.mempoolHasTx txh -mempoolSnapshotSizeAndCapacityAff - :: MkUniqueId - -> OgmiosWebSocket - -> Logger - -> MempoolSnapshotAcquired - -> Aff MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityAff u ogmiosWs logger ms = - mkOgmiosRequestAff ogmiosWs logger - (mempoolSnapshotSizeAndCapacityCall u ms) - _.mempoolSizeAndCapacity -- todo: typo - unit - -releaseMempoolAff - :: MkUniqueId - -> OgmiosWebSocket - -> Logger - -> MempoolSnapshotAcquired - -> Aff ReleasedMempool -releaseMempoolAff u ogmiosWs logger ms = - mkOgmiosRequestAff ogmiosWs logger (releaseMempoolCall u ms) - _.releaseMempool - unit - -mempoolSnapshotNextTxAff - :: MkUniqueId - -> OgmiosWebSocket - -> Logger - -> MempoolSnapshotAcquired - -> Aff (Maybe MempoolTransaction) -mempoolSnapshotNextTxAff u ogmiosWs logger ms = unwrap <$> - mkOgmiosRequestAff ogmiosWs logger (mempoolSnapshotNextTxCall u ms) - _.mempoolNextTx - unit - acquireMempoolSnapshotCall :: MkUniqueId -> JsonRpc2Call Unit MempoolSnapshotAcquired acquireMempoolSnapshotCall u = @@ -447,19 +390,7 @@ mkOgmiosWebSocketLens u logger isTxConfirmed = do let ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket ogmiosWebSocket ws = WebSocket ws - { chainTip: - mkListenerSet dispatcher pendingRequests - , evaluate: - mkListenerSet dispatcher pendingRequests - , getProtocolParameters: - mkListenerSet dispatcher pendingRequests - , eraSummaries: - mkListenerSet dispatcher pendingRequests - , currentEpoch: - mkListenerSet dispatcher pendingRequests - , systemStart: - mkListenerSet dispatcher pendingRequests - , acquireMempool: + { acquireMempool: mkListenerSet dispatcher pendingRequests , releaseMempool: mkListenerSet dispatcher pendingRequests @@ -469,12 +400,6 @@ mkOgmiosWebSocketLens u logger isTxConfirmed = do mkListenerSet dispatcher pendingRequests , mempoolSizeAndCapacity: mkListenerSet dispatcher pendingRequests - , submit: - mkSubmitTxListenerSet dispatcher pendingSubmitTxRequests - , stakePools: - mkListenerSet dispatcher pendingRequests - , delegationsAndRewards: - mkListenerSet dispatcher pendingRequests } resendPendingRequests :: JsWebSocket -> Effect Unit @@ -499,21 +424,11 @@ mkOgmiosWebSocketLens u logger isTxConfirmed = do -------------------------------------------------------------------------------- type OgmiosListeners = - { chainTip :: ListenerSet Unit ChainTipQR - , submit :: SubmitTxListenerSet - , evaluate :: - ListenerSet (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR - , getProtocolParameters :: ListenerSet Unit OgmiosProtocolParameters - , eraSummaries :: ListenerSet Unit OgmiosEraSummaries - , currentEpoch :: ListenerSet Unit CurrentEpoch - , systemStart :: ListenerSet Unit OgmiosSystemStart - , acquireMempool :: ListenerSet Unit MempoolSnapshotAcquired + { acquireMempool :: ListenerSet Unit MempoolSnapshotAcquired , releaseMempool :: ListenerSet Unit ReleasedMempool , mempoolHasTx :: ListenerSet TransactionHash HasTxR , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction , mempoolSizeAndCapacity :: ListenerSet Unit MempoolSizeAndCapacity - , stakePools :: ListenerSet StakePoolsQueryArgument PoolParametersR - , delegationsAndRewards :: ListenerSet (Array String) DelegationsAndRewardsR } -- convenience type for adding additional query types later @@ -529,9 +444,6 @@ type ListenerSet (request :: Type) (response :: Type) = -- to replay requests in case of a WebSocket failure. } -type SubmitTxListenerSet = ListenerSet (TransactionHash /\ CborBytes) - SubmitTxR - mkAddMessageListener :: forall (response :: Type) . DecodeOgmios response @@ -574,19 +486,6 @@ mkListenerSet dispatcher pendingRequests = Ref.modify_ (Map.insert reflection requestBody) pendingRequests } -mkSubmitTxListenerSet - :: Dispatcher -> PendingSubmitTxRequests -> SubmitTxListenerSet -mkSubmitTxListenerSet dispatcher pendingRequests = - { addMessageListener: - mkAddMessageListener dispatcher - , removeMessageListener: - mkRemoveMessageListener dispatcher pendingRequests - , addRequest: - \reflection (requestBody /\ txHash /\ _) -> - Ref.modify_ (Map.insert reflection (requestBody /\ txHash)) - pendingRequests - } - -- | Builds an Ogmios request action using `Aff` mkOgmiosRequestAff :: forall (request :: Type) (response :: Type) From 2d2196fa24a280defe1d67b0a77350c507a00aa4 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Fri, 7 Feb 2025 16:12:17 -0300 Subject: [PATCH 14/27] Omit "id" field for Ogmios HTTP request/response --- src/Internal/QueryM/Ogmios.purs | 12 ++---------- src/Internal/QueryM/Ogmios/Types.purs | 6 +++--- 2 files changed, 5 insertions(+), 13 deletions(-) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 8a32de2b16..687482f924 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -137,14 +137,7 @@ ogmiosQueryNoParams . DecodeOgmios a => String -> QueryM (Either OgmiosDecodeError a) -ogmiosQueryNoParams method = do - let - body = Aeson.encodeAeson - { jsonrpc: "2.0" - , id: "http-" <> method - , method - } - handleAffjaxOgmiosResponse <$> ogmiosPostRequest body +ogmiosQueryNoParams method = do ogmiosQueryParams method {} ogmiosQueryParams :: forall a p @@ -157,9 +150,8 @@ ogmiosQueryParams method params = do let body = Aeson.encodeAeson { jsonrpc: "2.0" - , id: "http-" <> method , method - , params: params + , params } handleAffjaxOgmiosResponse <$> ogmiosPostRequest body diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index de24b25023..e6e51df2d2 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -21,7 +21,6 @@ module Ctl.Internal.QueryM.Ogmios.Types , ogmiosDecodeErrorToError , decodeOgmios , class DecodeOgmios - , JsonRpc2Response , OgmiosDecodeError ( ResultDecodingError , ClientErrorResponse @@ -58,6 +57,7 @@ import Aeson , fromString , getField , getFieldOptional + , getFieldOptional' , isNull , printJsonDecodeError , stringifyAeson @@ -1125,7 +1125,7 @@ type JsonRpc2Response = , method :: Maybe String , result :: Maybe Aeson , error :: Maybe Aeson - , id :: String + , id :: Maybe String } decodeAesonJsonRpc2Response @@ -1135,7 +1135,7 @@ decodeAesonJsonRpc2Response = aesonObject $ \o -> do method <- getFieldOptional o "method" result <- getFieldOptional o "result" error <- getFieldOptional o "error" - id <- getField o "id" + id <- getFieldOptional' o "id" pure { jsonrpc , method From 2c8db1f07d68f8a80fd436cbf2478304e5e92d01 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Fri, 7 Feb 2025 16:30:52 -0300 Subject: [PATCH 15/27] Simplify error handling --- src/Internal/QueryM/CurrentEpoch.purs | 11 +++++----- src/Internal/QueryM/EraSummaries.purs | 10 ++++----- src/Internal/QueryM/Ogmios.purs | 19 +++++++----------- src/Internal/QueryM/Pools.purs | 29 ++++++++++++--------------- 4 files changed, 29 insertions(+), 40 deletions(-) diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index c01c2f0131..48e3ff7679 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -9,14 +9,13 @@ import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.Ogmios (currentEpoch) as Ogmios import Ctl.Internal.QueryM.Ogmios.Types (CurrentEpoch, pprintOgmiosDecodeError) -import Data.Either (Either(Right, Left)) +import Data.Either (either) import Effect.Exception (error) -- | Get the current Epoch. Details can be found https://ogmios.dev/api/ under -- | "currentEpoch" query getCurrentEpoch :: QueryM CurrentEpoch -getCurrentEpoch = do - resp <- Ogmios.currentEpoch - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure val +getCurrentEpoch = Ogmios.currentEpoch + >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + pure diff --git a/src/Internal/QueryM/EraSummaries.purs b/src/Internal/QueryM/EraSummaries.purs index 0eb8dafa6e..c3e6b5e9d3 100644 --- a/src/Internal/QueryM/EraSummaries.purs +++ b/src/Internal/QueryM/EraSummaries.purs @@ -10,15 +10,13 @@ import Control.Monad.Error.Class (throwError) import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.Ogmios (eraSummaries) as Ogmios import Ctl.Internal.QueryM.Ogmios.Types (pprintOgmiosDecodeError) -import Data.Either (Either(Right, Left)) +import Data.Either (either) import Data.Newtype (unwrap) import Effect.Exception (error) -- | Get `EraSummaries` as used for Slot arithemetic. Details can be found -- | https://ogmios.dev/api/ under "eraSummaries" query getEraSummaries :: QueryM EraSummaries -getEraSummaries = do - resp <- Ogmios.eraSummaries - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure $ unwrap $ val +getEraSummaries = Ogmios.eraSummaries + >>= either (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< unwrap) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 687482f924..67b236ccab 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -53,7 +53,7 @@ import Ctl.Internal.QueryM.Ogmios.Types import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) import Data.Bifunctor (lmap) import Data.ByteArray (byteArrayToHex) -import Data.Either (Either(Right, Left)) +import Data.Either (Either(Right, Left), either) import Data.HTTP.Method (Method(POST)) import Data.Lens (_Right, to, (^?)) import Data.Maybe (Maybe(Just)) @@ -219,11 +219,9 @@ ogmiosErrorHandler => MonadThrow Error m => m (Either OgmiosDecodeError a) -> m a -ogmiosErrorHandler fun = do - resp <- fun - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure val +ogmiosErrorHandler fun = fun >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + pure ogmiosErrorHandlerWithArg :: forall a m b @@ -232,9 +230,6 @@ ogmiosErrorHandlerWithArg => (a -> m (Either OgmiosDecodeError b)) -> a -> m b -ogmiosErrorHandlerWithArg fun arg = do - resp <- fun arg - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure val - +ogmiosErrorHandlerWithArg fun arg = fun arg >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + pure diff --git a/src/Internal/QueryM/Pools.purs b/src/Internal/QueryM/Pools.purs index ac4162f020..9fb300c070 100644 --- a/src/Internal/QueryM/Pools.purs +++ b/src/Internal/QueryM/Pools.purs @@ -23,7 +23,7 @@ import Ctl.Internal.QueryM.Ogmios.Types ) import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) import Data.ByteArray (byteArrayToHex) -import Data.Either (Either(Right, Left)) +import Data.Either (either) import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(Nothing, Just)) @@ -37,11 +37,10 @@ import Record.Builder (build, merge) getStakePools :: Maybe (Array PoolPubKeyHash) -> QueryM (Map PoolPubKeyHash PoolParameters) -getStakePools selected = do - resp <- Ogmios.poolParameters $ wrap selected - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure $ unwrap val +getStakePools selected = + Ogmios.poolParameters (wrap selected) >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< unwrap) getPoolIds :: QueryM (Array PoolPubKeyHash) getPoolIds = (Map.toUnfoldableUnordered >>> map fst) <$> @@ -72,11 +71,10 @@ getPoolsParameters poolPubKeyHashes = do getValidatorHashDelegationsAndRewards :: StakeValidatorHash -> QueryM (Maybe DelegationsAndRewards) -getValidatorHashDelegationsAndRewards skh = do - resp <- Ogmios.delegationsAndRewards [ stringRep ] - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure $ Map.lookup byteHex $ unwrap val +getValidatorHashDelegationsAndRewards skh = + Ogmios.delegationsAndRewards [ stringRep ] >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< Map.lookup byteHex <<< unwrap) where stringRep :: String stringRep = unsafePartial $ ScriptHash.toBech32Unsafe "script" $ unwrap skh @@ -87,11 +85,10 @@ getValidatorHashDelegationsAndRewards skh = do -- TODO: batched variant getPubKeyHashDelegationsAndRewards :: StakePubKeyHash -> QueryM (Maybe DelegationsAndRewards) -getPubKeyHashDelegationsAndRewards pkh = do - resp <- Ogmios.delegationsAndRewards [ stringRep ] - case resp of - Left err -> throwError $ error $ pprintOgmiosDecodeError err - Right val -> pure $ Map.lookup byteHex $ unwrap val +getPubKeyHashDelegationsAndRewards pkh = + Ogmios.delegationsAndRewards [ stringRep ] >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< Map.lookup byteHex <<< unwrap) where stringRep :: String stringRep = unsafePartial From 796868f395da5cbc0d35696ba09b459660d990b9 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Fri, 7 Feb 2025 16:31:16 -0300 Subject: [PATCH 16/27] Reuse `aesonObject` --- src/Internal/QueryM/Ogmios/JsonRpc2.purs | 20 +++----------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/JsonRpc2.purs index 24f64a4e8d..e2de0b3339 100644 --- a/src/Internal/QueryM/Ogmios/JsonRpc2.purs +++ b/src/Internal/QueryM/Ogmios/JsonRpc2.purs @@ -10,17 +10,10 @@ module Ctl.Internal.QueryM.Ogmios.JsonRpc2 import Prelude -import Aeson - ( class EncodeAeson - , Aeson - , JsonDecodeError(TypeMismatch) - , caseAesonObject - , encodeAeson - , getField - ) -import Data.Either (Either(Left)) +import Aeson (class EncodeAeson, Aeson, JsonDecodeError, encodeAeson, getField) +import Ctl.Internal.Service.Helpers (aesonObject) +import Data.Either (Either) import Effect (Effect) -import Foreign.Object (Object) import Record as Record -- | Structure of all json rpc2.0 websocket requests @@ -80,10 +73,3 @@ parseJsonRpc2ResponseId parseJsonRpc2ResponseId = aesonObject $ flip getField "id" --- | Helper for assuming we get an object -aesonObject - :: forall (a :: Type) - . (Object Aeson -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonObject = caseAesonObject (Left (TypeMismatch "expected object")) From 9a214a8be092a8957a5d85c1a5f200a0d0a5811f Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Mon, 10 Feb 2025 09:53:22 -0300 Subject: [PATCH 17/27] Simplify error handling --- src/Internal/QueryM/Ogmios/Types.purs | 26 +++++++++++++------------- test/Ogmios/EvaluateTx.purs | 22 +++++++++++++++------- 2 files changed, 28 insertions(+), 20 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index e6e51df2d2..66ebce620a 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -22,9 +22,8 @@ module Ctl.Internal.QueryM.Ogmios.Types , decodeOgmios , class DecodeOgmios , OgmiosDecodeError - ( ResultDecodingError - , ClientErrorResponse - , InvalidResponse + ( ClientErrorResponse + , InvalidRpcResponse , ErrorResponse ) , OgmiosEraSummaries(OgmiosEraSummaries) @@ -65,7 +64,10 @@ import Aeson , (.:?) ) import Cardano.AsCbor (decodeCbor, encodeCbor) -import Cardano.Provider.Error (ClientError, pprintClientError) +import Cardano.Provider.Error + ( ClientError(ClientDecodeJsonError) + , pprintClientError + ) import Cardano.Provider.TxEvaluation ( ExecutionUnits , OgmiosTxOut @@ -1045,10 +1047,8 @@ data OgmiosDecodeError = ErrorResponse (Maybe OgmiosError) -- Server responded with result, parsing of which failed | ClientErrorResponse ClientError - -- Server responded with result, parsing of which failed - | ResultDecodingError JsonDecodeError -- Received JsonRpc2Response was not of the right format. - | InvalidResponse JsonDecodeError + | InvalidRpcResponse JsonDecodeError derive instance Generic OgmiosDecodeError _ @@ -1060,9 +1060,7 @@ pprintOgmiosDecodeError (ErrorResponse err) = "Ogmios responded with error: " <> maybe "" pprintOgmiosError err pprintOgmiosDecodeError (ClientErrorResponse err) = "Ogmios responded with error: " <> pprintClientError err -pprintOgmiosDecodeError (ResultDecodingError err) = - "Failed to parse the result: " <> printJsonDecodeError err -pprintOgmiosDecodeError (InvalidResponse err) = +pprintOgmiosDecodeError (InvalidRpcResponse err) = "Ogmios response was not of the right format: " <> printJsonDecodeError err ogmiosDecodeErrorToError :: OgmiosDecodeError -> Error @@ -1084,20 +1082,22 @@ makeDecodeOgmios -> Aeson -> Either OgmiosDecodeError o makeDecodeOgmios decoders aeson = do - json <- lmap InvalidResponse $ decodeAesonJsonRpc2Response aeson + json <- lmap InvalidRpcResponse $ decodeAesonJsonRpc2Response aeson let merr = _.parseError <$> theseLeft decoders <*> json.error let mres = _.parseResult <$> theseRight decoders <*> json.result case (mres /\ merr) of -- Expected result, got it Just (Right x) /\ _ -> pure x -- Expected result, got it in a wrong format - Just (Left err) /\ _ -> Left $ ResultDecodingError err + Just (Left err) /\ _ -> Left $ ClientErrorResponse $ ClientDecodeJsonError + (stringifyAeson aeson) + err -- Got an expected error _ /\ Just (Right x) -> pure x -- Got an unexpected error _ -> do err :: Maybe OgmiosError <- sequence $ - lmap InvalidResponse <<< decodeAeson <$> json.error + lmap InvalidRpcResponse <<< decodeAeson <$> json.error Left $ ErrorResponse err -- | Decode "result" field of ogmios response. diff --git a/test/Ogmios/EvaluateTx.purs b/test/Ogmios/EvaluateTx.purs index fd81e2ea16..6496a0b93c 100644 --- a/test/Ogmios/EvaluateTx.purs +++ b/test/Ogmios/EvaluateTx.purs @@ -2,7 +2,8 @@ module Test.Ctl.Ogmios.EvaluateTx (suite) where import Prelude -import Aeson (JsonDecodeError(TypeMismatch)) +import Aeson (stringifyAeson) +import Cardano.Provider.Error (ClientError(ClientDecodeJsonError)) import Cardano.Provider.TxEvaluation ( ExecutionUnits , RedeemerPointer @@ -14,7 +15,7 @@ import Cardano.Types (BigNum) import Cardano.Types.BigNum as BigNum import Cardano.Types.RedeemerTag (RedeemerTag(Spend, Cert, Reward)) import Ctl.Internal.QueryM.Ogmios.Types - ( OgmiosDecodeError(ResultDecodingError) + ( OgmiosDecodeError(ClientErrorResponse) , OgmiosTxEvaluationR , decodeOgmios ) @@ -52,12 +53,19 @@ suite = do _ -> false test "Fails to decode a response with invalid redeemer pointer format" do - txEvalR :: Either OgmiosDecodeError TxEvaluationR <- - (map (\(r :: OgmiosTxEvaluationR) -> unwrap r) <<< decodeOgmios) <$> - liftEffect - ogmiosEvaluateTxInvalidPointerFormatFixture + body <- liftEffect ogmiosEvaluateTxInvalidPointerFormatFixture + let + (txEvalR :: Either OgmiosDecodeError TxEvaluationR) = + (map (\(r :: OgmiosTxEvaluationR) -> unwrap r) <<< decodeOgmios) + body txEvalR `shouldSatisfy` case _ of - Left (ResultDecodingError (TypeMismatch _)) -> true + Left + ( ClientErrorResponse + ( ClientDecodeJsonError + bodyStr + _ + ) + ) -> bodyStr == stringifyAeson body _ -> false test "Successfully decodes a failed execution response (Incompatible era)" From f8fea7c3c6fe9111df496281199ebfbeb112a81c Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Mon, 10 Feb 2025 11:08:11 -0300 Subject: [PATCH 18/27] Add `HttpUtils` --- src/Internal/QueryM.purs | 29 ++++++---------- src/Internal/QueryM/HttpUtils.purs | 54 ++++++++++++++++++++++++++++++ src/Internal/QueryM/Ogmios.purs | 28 ++++++++-------- 3 files changed, 78 insertions(+), 33 deletions(-) create mode 100644 src/Internal/QueryM/HttpUtils.purs diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 67b8590429..294b921dcb 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -30,6 +30,7 @@ import Control.Monad.Rec.Class (class MonadRec) import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) import Ctl.Internal.Helpers (logWithLevel) +import Ctl.Internal.QueryM.HttpUtils (handleAffjaxResponseGeneric) import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryRuntime) import Ctl.Internal.ServerConfig (ServerConfig) import Data.Bifunctor (lmap) @@ -128,27 +129,17 @@ instance Parallel (QueryMT ParAff) (QueryMT Aff) where sequential :: QueryMT ParAff ~> QueryMT Aff sequential = wrap <<< sequential <<< unwrap --------------------------------------------------------------------------------- --- Affjax --------------------------------------------------------------------------------- - --- Checks response status code and returns `ClientError` in case of failure, --- otherwise attempts to decode the result. --- --- This function solves the problem described there: --- https://github.com/eviefp/purescript-affjax-errors handleAffjaxResponse :: forall (result :: Type) . DecodeAeson result => Either Affjax.Error (Affjax.Response String) -> Either ClientError result -handleAffjaxResponse (Left affjaxError) = - Left (ClientHttpError affjaxError) -handleAffjaxResponse - (Right { status: Affjax.StatusCode.StatusCode statusCode, body }) - | statusCode < 200 || statusCode > 299 = - Left $ ClientHttpResponseError (wrap statusCode) $ ServiceOtherError body - | otherwise = - body # lmap (ClientDecodeJsonError body) - <<< (decodeAeson <=< parseJsonStringToAeson) - +handleAffjaxResponse = + handleAffjaxResponseGeneric + ClientHttpError + ( \statusCode body -> ClientHttpResponseError (wrap statusCode) + (ServiceOtherError body) + ) + ClientDecodeJsonError + (decodeAeson <=< parseJsonStringToAeson) + pure diff --git a/src/Internal/QueryM/HttpUtils.purs b/src/Internal/QueryM/HttpUtils.purs new file mode 100644 index 0000000000..02f2fa6d16 --- /dev/null +++ b/src/Internal/QueryM/HttpUtils.purs @@ -0,0 +1,54 @@ +-- | This module defines utilities for working with HTTP requests +module Ctl.Internal.QueryM.HttpUtils + ( handleAffjaxResponseGeneric + ) where + +import Prelude + +import Aeson (JsonDecodeError) +import Affjax (Error, Response) as Affjax +import Affjax.StatusCode as Affjax.StatusCode +import Data.Bifunctor (lmap) +import Data.Either (Either(Left, Right)) + +-------------------------------------------------------------------------------- +-- Affjax +-------------------------------------------------------------------------------- + +-- Checks response status code and returns `ClientError` in case of failure, +-- otherwise attempts to decode the result. +-- +-- This function solves the problem described there: +-- https://github.com/eviefp/purescript-affjax-errors + +handleAffjaxResponseGeneric + :: forall err intermediate result + . (Affjax.Error -> err) + -- ^ Convert an Affjax error into custom error + -> (Int -> String -> err) + -- ^ Convert a non-2xx status code into custom error + -> (String -> JsonDecodeError -> err) + -- ^ Wrap aeson-parse/decode errors + -> (String -> Either JsonDecodeError intermediate) + -- ^ Parse the response body + -> (intermediate -> Either err result) + -- ^ Function from `intermediate` to `result` + -> Either Affjax.Error (Affjax.Response String) + -- ^ Argument + -> Either err result +handleAffjaxResponseGeneric + mkHttpError + mkHttpResponseError + mkDecodeError + decodeAeson + mkResult = + case _ of + Left affjaxError -> + Left (mkHttpError affjaxError) + Right { status: Affjax.StatusCode.StatusCode statusCode, body } + | statusCode < 200 || statusCode > 299 -> + Left (mkHttpResponseError statusCode body) + | otherwise -> do + intermediate <- lmap (mkDecodeError body) do + decodeAeson body + mkResult intermediate diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 67b236ccab..f2f45d7d27 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -21,7 +21,7 @@ import Affjax.ResponseFormat (string) as Affjax.ResponseFormat import Affjax.StatusCode (StatusCode(StatusCode)) import Affjax.StatusCode as Affjax.StatusCode import Cardano.Provider.Error - ( ClientError(ClientHttpError, ClientHttpResponseError) + ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) , ServiceError(ServiceOtherError) ) import Cardano.Provider.TxEvaluation as Provider @@ -33,13 +33,14 @@ import Control.Monad.Error.Class (class MonadThrow, throwError) import Control.Monad.Reader.Class (asks) import Ctl.Internal.Affjax (request) as Affjax import Ctl.Internal.QueryM (QueryM) +import Ctl.Internal.QueryM.HttpUtils (handleAffjaxResponseGeneric) import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios , AdditionalUtxoSet , ChainTipQR(CtChainPoint, CtChainOrigin) , CurrentEpoch , DelegationsAndRewardsR - , OgmiosDecodeError(ResultDecodingError, ClientErrorResponse) + , OgmiosDecodeError(ClientErrorResponse) , OgmiosEraSummaries , OgmiosProtocolParameters , OgmiosSystemStart @@ -137,7 +138,7 @@ ogmiosQueryNoParams . DecodeOgmios a => String -> QueryM (Either OgmiosDecodeError a) -ogmiosQueryNoParams method = do ogmiosQueryParams method {} +ogmiosQueryNoParams = flip ogmiosQueryParams {} ogmiosQueryParams :: forall a p @@ -201,17 +202,16 @@ handleAffjaxOgmiosResponse . DecodeOgmios result => Either Affjax.Error (Affjax.Response String) -> Either OgmiosDecodeError result -handleAffjaxOgmiosResponse (Left affjaxError) = - Left (ClientErrorResponse $ ClientHttpError affjaxError) -handleAffjaxOgmiosResponse - (Right { status: Affjax.StatusCode.StatusCode statusCode, body }) - | statusCode < 200 || statusCode > 299 = - Left $ ClientErrorResponse $ ClientHttpResponseError (wrap statusCode) $ - ServiceOtherError body - | otherwise = do - aeson <- lmap ResultDecodingError - $ parseJsonStringToAeson body - decodeOgmios aeson +handleAffjaxOgmiosResponse = + handleAffjaxResponseGeneric + (ClientErrorResponse <<< ClientHttpError) + ( \statusCode body -> ClientErrorResponse $ ClientHttpResponseError + (wrap statusCode) + (ServiceOtherError body) + ) + (\body -> ClientErrorResponse <<< ClientDecodeJsonError body) + parseJsonStringToAeson + decodeOgmios ogmiosErrorHandler :: forall a m From adba5b1400d31b7850be151e7b389e33b69e30bc Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Mon, 10 Feb 2025 11:10:55 -0300 Subject: [PATCH 19/27] Clean duplicated code --- src/Internal/QueryM.purs | 4 +-- src/Internal/QueryM/Ogmios.purs | 4 +-- src/Internal/QueryM/Ogmios/Mempool.purs | 4 +-- src/Internal/QueryM/Ogmios/Types.purs | 38 +------------------------ src/Internal/Service/Helpers.purs | 8 ++++++ src/Internal/Types/Interval.purs | 2 +- test/Ogmios/Aeson.purs | 7 ++--- 7 files changed, 15 insertions(+), 52 deletions(-) diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 294b921dcb..defc66e332 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -14,7 +14,6 @@ import Prelude import Aeson (class DecodeAeson, decodeAeson, parseJsonStringToAeson) import Affjax (Error, Response) as Affjax -import Affjax.StatusCode as Affjax.StatusCode import Cardano.Provider.Error ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) , ServiceError(ServiceOtherError) @@ -33,8 +32,7 @@ import Ctl.Internal.Helpers (logWithLevel) import Ctl.Internal.QueryM.HttpUtils (handleAffjaxResponseGeneric) import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryRuntime) import Ctl.Internal.ServerConfig (ServerConfig) -import Data.Bifunctor (lmap) -import Data.Either (Either(Left, Right)) +import Data.Either (Either) import Data.Log.Level (LogLevel) import Data.Log.Message (Message) import Data.Maybe (Maybe, fromMaybe) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index f2f45d7d27..5b94985458 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -19,7 +19,6 @@ import Affjax.RequestBody as Affjax.RequestBody import Affjax.RequestHeader as Affjax.RequestHeader import Affjax.ResponseFormat (string) as Affjax.ResponseFormat import Affjax.StatusCode (StatusCode(StatusCode)) -import Affjax.StatusCode as Affjax.StatusCode import Cardano.Provider.Error ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) , ServiceError(ServiceOtherError) @@ -52,9 +51,8 @@ import Ctl.Internal.QueryM.Ogmios.Types , pprintOgmiosDecodeError ) import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) -import Data.Bifunctor (lmap) import Data.ByteArray (byteArrayToHex) -import Data.Either (Either(Right, Left), either) +import Data.Either (Either(Left), either) import Data.HTTP.Method (Method(POST)) import Data.Lens (_Right, to, (^?)) import Data.Maybe (Maybe(Just)) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index 5450d0241c..cd90fe314d 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -76,14 +76,12 @@ import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios , OgmiosDecodeError - , aesonNull - , aesonObject - , aesonString , decodeOgmios , decodeResult , ogmiosDecodeErrorToError , submitSuccessPartialResp ) +import Ctl.Internal.Service.Helpers (aesonNull, aesonObject, aesonString) import Data.Argonaut.Encode.Encoders as Argonaut import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right), either, isRight) diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index 66ebce620a..c470597c48 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -31,12 +31,9 @@ module Ctl.Internal.QueryM.Ogmios.Types , SubmitTxR(SubmitTxSuccess, SubmitFail) , StakePoolsQueryArgument(StakePoolsQueryArgument) , OgmiosTxEvaluationR(OgmiosTxEvaluationR) - , aesonObject , submitSuccessPartialResp , parseIpv6String , rationalToSubcoin - , aesonNull - , aesonString ) where import Prelude @@ -46,9 +43,6 @@ import Aeson , class EncodeAeson , Aeson , JsonDecodeError(TypeMismatch, MissingValue, AtKey) - , caseAesonArray - , caseAesonNull - , caseAesonObject , caseAesonString , decodeAeson , encodeAeson @@ -141,6 +135,7 @@ import Cardano.Types.Value (Value, getMultiAsset, valueToCoin) import Control.Alt ((<|>)) import Control.Alternative (guard) import Ctl.Internal.Helpers (encodeMap, showWithParens) +import Ctl.Internal.Service.Helpers (aesonArray, aesonObject, aesonString) import Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) ) @@ -990,37 +985,6 @@ instance EncodeAeson AdditionalUtxoSet where (\m' (k /\ v) -> Map.insert (f k) v m') Map.empty --- helper for assuming we get an object -aesonObject - :: forall (a :: Type) - . (Object Aeson -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonObject = caseAesonObject (Left (TypeMismatch "Expected Object")) - --- helper for assuming we get an array -aesonArray - :: forall (a :: Type) - . (Array Aeson -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonArray = caseAesonArray (Left (TypeMismatch "Expected Array")) - --- Helper that decodes a string -aesonString - :: forall (a :: Type) - . (String -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonString = caseAesonString (Left (TypeMismatch "Expected String")) - --- Helper that decodes a null -aesonNull - :: forall (a :: Type) - . Aeson - -> Either JsonDecodeError Unit -aesonNull = caseAesonNull (Left (TypeMismatch "Expected Null")) pure - -- Decode utilities newtype OgmiosError = OgmiosError diff --git a/src/Internal/Service/Helpers.purs b/src/Internal/Service/Helpers.purs index a8fa09dab1..7da7279e1c 100644 --- a/src/Internal/Service/Helpers.purs +++ b/src/Internal/Service/Helpers.purs @@ -2,6 +2,7 @@ module Ctl.Internal.Service.Helpers ( aesonArray , aesonString , aesonObject + , aesonNull , decodeAssetClass ) where @@ -11,6 +12,7 @@ import Aeson ( Aeson , JsonDecodeError(TypeMismatch) , caseAesonArray + , caseAesonNull , caseAesonObject , caseAesonString ) @@ -46,6 +48,12 @@ aesonString -> Either JsonDecodeError a aesonString = caseAesonString (Left (TypeMismatch "String")) +aesonNull + :: forall (a :: Type) + . Aeson + -> Either JsonDecodeError Unit +aesonNull = caseAesonNull (Left (TypeMismatch "Null")) pure + decodeAssetClass :: String -> String diff --git a/src/Internal/Types/Interval.purs b/src/Internal/Types/Interval.purs index f53368150c..fb126ced65 100644 --- a/src/Internal/Types/Interval.purs +++ b/src/Internal/Types/Interval.purs @@ -104,7 +104,7 @@ import Ctl.Internal.Helpers , showWithParens , unsafeFromJust ) -import Ctl.Internal.QueryM.Ogmios.Types (aesonObject) +import Ctl.Internal.Service.Helpers (aesonObject) import Ctl.Internal.Types.SystemStart (SystemStart, sysStartUnixTime) import Data.Argonaut.Encode.Encoders (encodeString) import Data.Array (find, head, index, length) diff --git a/test/Ogmios/Aeson.purs b/test/Ogmios/Aeson.purs index 35f871d77e..9e99c55c36 100644 --- a/test/Ogmios/Aeson.purs +++ b/test/Ogmios/Aeson.purs @@ -10,19 +10,16 @@ import Aeson as Aeson import Control.Monad.Error.Class (liftEither) import Control.Monad.Trans.Class (lift) import Control.Parallel (parTraverse) -import Ctl.Internal.QueryM.Ogmios.Mempool - ( HasTxR - , MempoolSizeAndCapacity - ) as Mempool +import Ctl.Internal.QueryM.Ogmios.Mempool (HasTxR, MempoolSizeAndCapacity) as Mempool import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios , OgmiosDecodeError(ErrorResponse) , OgmiosTxEvaluationR , SubmitTxR - , aesonObject , decodeOgmios ) import Ctl.Internal.QueryM.Ogmios.Types as O +import Ctl.Internal.Service.Helpers (aesonObject) import Data.Array (catMaybes, groupAllBy, nubBy) import Data.Array.NonEmpty (NonEmptyArray, head, length, tail) import Data.Bifunctor (lmap) From febc66a323114f7fd7861d5c5f21fb3bdd135b88 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Thu, 13 Feb 2025 20:44:47 -0300 Subject: [PATCH 20/27] Remove websocket runtime from `QueryEnv` --- src/Contract/Backend/Ogmios/Mempool.purs | 172 +++++++++++---------- src/Internal/Contract/Monad.purs | 39 +---- src/Internal/Contract/ProviderBackend.purs | 6 +- src/Internal/QueryM.purs | 2 - src/Internal/QueryM/Ogmios/JsonRpc2.js | 5 + src/Internal/QueryM/Ogmios/JsonRpc2.purs | 15 +- src/Internal/QueryM/Ogmios/Mempool.purs | 87 +++++------ src/Internal/QueryM/Ogmios/QueryEnv.purs | 15 -- src/Internal/Test/E2E/Runner.purs | 2 +- test/Ogmios/GenerateFixtures.purs | 3 +- test/Testnet.purs | 36 +---- test/Testnet/Contract/OgmiosMempool.purs | 63 ++++++-- 12 files changed, 205 insertions(+), 240 deletions(-) create mode 100644 src/Internal/QueryM/Ogmios/JsonRpc2.js delete mode 100644 src/Internal/QueryM/Ogmios/QueryEnv.purs diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index e3623cb81b..aa373406f7 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -3,12 +3,15 @@ -- | https://ogmios.dev/mini-protocols/local-tx-monitor/ module Contract.Backend.Ogmios.Mempool ( acquireMempoolSnapshot - , fetchMempoolTxs , mempoolSnapshotHasTx , mempoolSnapshotNextTx + , fetchMempoolTxs , mempoolSnapshotSizeAndCapacity , releaseMempool , withMempoolSnapshot + , MempoolEnv + , MempoolMT(MempoolMT) + , MempoolM ) where import Contract.Prelude @@ -16,17 +19,21 @@ import Contract.Prelude import Cardano.AsCbor (decodeCbor) import Cardano.Types.Transaction (Transaction) import Cardano.Types.TransactionHash (TransactionHash) -import Contract.Monad (Contract) -import Control.Monad.Error.Class (liftMaybe, try) -import Control.Monad.Reader.Trans (asks) -import Ctl.Internal.Contract.Monad (wrapQueryM) +import Control.Monad.Error.Class + ( class MonadError + , class MonadThrow + , liftMaybe + , try + ) +import Control.Monad.Reader.Class (class MonadAsk) +import Control.Monad.Reader.Trans (ReaderT(ReaderT), asks) import Ctl.Internal.Logging (Logger, mkLogger) -import Ctl.Internal.QueryM (QueryM) import Ctl.Internal.QueryM.Ogmios.JsWebSocket (JsWebSocket) import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , OgmiosListeners + , OgmiosWebSocket , acquireMempoolSnapshotCall , listeners , mempoolSnapshotHasTxCall @@ -41,59 +48,56 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , MempoolSnapshotAcquired , MempoolTransaction(MempoolTransaction) ) as Ogmios -import Ctl.Internal.QueryM.UniqueId (uniqueId) import Data.Array as Array import Data.ByteArray (hexToByteArray) import Data.List (List(Cons)) -import Data.Maybe (Maybe(Just, Nothing)) -import Data.Newtype (unwrap) -import Effect.Aff.Class (liftAff) -import Effect.Exception (error) - --- | Establish a connection with the Local TX Monitor. --- | Instantly accquires the current mempool snapshot, and will wait for the next --- | mempool snapshot if used again before using `releaseMempool`. -acquireMempoolSnapshot :: Contract Ogmios.MempoolSnapshotAcquired -acquireMempoolSnapshot = wrapQueryM acquireMempoolSnapshotFetch - --- | Check to see if a TxHash is present in the current mempool snapshot. -mempoolSnapshotHasTx - :: Ogmios.MempoolSnapshotAcquired -> TransactionHash -> Contract Boolean -mempoolSnapshotHasTx ms = wrapQueryM <<< mempoolSnapshotHasTxFetch ms - --- | Get the first received TX in the current mempool snapshot. This function can --- | be recursively called to traverse the finger-tree of the mempool data set. --- | This will return `Nothing` once it has reached the end of the current mempool. -mempoolSnapshotNextTx - :: Ogmios.MempoolSnapshotAcquired - -> Contract (Maybe Transaction) -mempoolSnapshotNextTx mempoolAcquired = do - mbTx <- wrapQueryM $ mempoolSnapshotNextTxFetch mempoolAcquired - for mbTx \(Ogmios.MempoolTransaction { raw }) -> do - byteArray <- liftMaybe (error "Failed to decode transaction") - $ hexToByteArray raw - liftMaybe (error "Failed to decode tx") - $ decodeCbor - $ wrap byteArray - --- | The acquired snapshot’s size (in bytes), number of transactions, and --- | capacity (in bytes). -mempoolSnapshotSizeAndCapacity - :: Ogmios.MempoolSnapshotAcquired -> Contract Ogmios.MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacity = wrapQueryM <<< - mempoolSnapshotSizeAndCapacityFetch - --- | Release the connection to the Local TX Monitor. -releaseMempool - :: Ogmios.MempoolSnapshotAcquired -> Contract Unit -releaseMempool = wrapQueryM <<< releaseMempoolFetch +import Data.Log.Level (LogLevel) +import Data.Log.Message (Message) +import Data.Maybe (Maybe) +import Data.Newtype (class Newtype, unwrap) +import Effect.Aff (Aff) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Class (class MonadEffect) +import Effect.Exception (Error, error) + +---------------- +-- Mempool monad +---------------- + +type MempoolEnv = + { ogmiosWs :: OgmiosWebSocket + , logLevel :: LogLevel + , customLogger :: Maybe (LogLevel -> Message -> Aff Unit) + , suppressLogs :: Boolean + } + +type MempoolM = MempoolMT Aff + +newtype MempoolMT (m :: Type -> Type) (a :: Type) = + MempoolMT (ReaderT MempoolEnv m a) + +derive instance Newtype (MempoolMT m a) _ +derive newtype instance Functor m => Functor (MempoolMT m) +derive newtype instance Apply m => Apply (MempoolMT m) +derive newtype instance Applicative m => Applicative (MempoolMT m) +derive newtype instance Bind m => Bind (MempoolMT m) +derive newtype instance Monad (MempoolMT Aff) +derive newtype instance MonadEffect (MempoolMT Aff) +derive newtype instance MonadAff (MempoolMT Aff) +derive newtype instance MonadThrow Error (MempoolMT Aff) +derive newtype instance MonadError Error (MempoolMT Aff) +derive newtype instance MonadAsk MempoolEnv (MempoolMT Aff) + +-------------------- +-- Mempool functions +-------------------- -- | A bracket-style function for working with mempool snapshots - ensures -- | release in the presence of exceptions withMempoolSnapshot :: forall a - . (Ogmios.MempoolSnapshotAcquired -> Contract a) - -> Contract a + . (Ogmios.MempoolSnapshotAcquired -> MempoolM a) + -> MempoolM a withMempoolSnapshot f = do s <- acquireMempoolSnapshot res <- try $ f s @@ -104,7 +108,7 @@ withMempoolSnapshot f = do -- | respond with a new TX. fetchMempoolTxs :: Ogmios.MempoolSnapshotAcquired - -> Contract (Array Transaction) + -> MempoolM (Array Transaction) fetchMempoolTxs ms = Array.fromFoldable <$> go where go = do @@ -113,61 +117,67 @@ fetchMempoolTxs ms = Array.fromFoldable <$> go Just tx -> Cons tx <$> go Nothing -> pure mempty -acquireMempoolSnapshotFetch - :: QueryM Ogmios.MempoolSnapshotAcquired -acquireMempoolSnapshotFetch = +acquireMempoolSnapshot + :: MempoolM Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshot = mkOgmiosRequest - (acquireMempoolSnapshotCall uniqueId) + acquireMempoolSnapshotCall _.acquireMempool unit -mempoolSnapshotHasTxFetch +mempoolSnapshotHasTx :: Ogmios.MempoolSnapshotAcquired -> TransactionHash - -> QueryM Boolean -mempoolSnapshotHasTxFetch ms txh = + -> MempoolM Boolean +mempoolSnapshotHasTx ms txh = unwrap <$> mkOgmiosRequest - (mempoolSnapshotHasTxCall uniqueId ms) + (mempoolSnapshotHasTxCall ms) _.mempoolHasTx txh -mempoolSnapshotSizeAndCapacityFetch +mempoolSnapshotSizeAndCapacity :: Ogmios.MempoolSnapshotAcquired - -> QueryM Ogmios.MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityFetch ms = + -> MempoolM Ogmios.MempoolSizeAndCapacity +mempoolSnapshotSizeAndCapacity ms = mkOgmiosRequest - (mempoolSnapshotSizeAndCapacityCall uniqueId ms) + (mempoolSnapshotSizeAndCapacityCall ms) _.mempoolSizeAndCapacity unit -releaseMempoolFetch +releaseMempool :: Ogmios.MempoolSnapshotAcquired - -> QueryM Unit -releaseMempoolFetch ms = + -> MempoolM Unit +releaseMempool ms = unit <$ mkOgmiosRequest - (releaseMempoolCall uniqueId ms) + (releaseMempoolCall ms) _.releaseMempool unit -mempoolSnapshotNextTxFetch +mempoolSnapshotNextTx :: Ogmios.MempoolSnapshotAcquired - -> QueryM (Maybe Ogmios.MempoolTransaction) -mempoolSnapshotNextTxFetch ms = - unwrap <$> mkOgmiosRequest - (mempoolSnapshotNextTxCall uniqueId ms) + -> MempoolM (Maybe Transaction) +mempoolSnapshotNextTx ms = do + mbTx <- unwrap <$> mkOgmiosRequest + (mempoolSnapshotNextTxCall ms) _.mempoolNextTx unit + for mbTx \(Ogmios.MempoolTransaction { raw }) -> do + byteArray <- liftMaybe (error "Failed to decode transaction") + $ hexToByteArray raw + liftMaybe (error "Failed to decode tx") + $ decodeCbor + $ wrap byteArray --- | Builds an Ogmios request action using `QueryM` +-- | Builds an Ogmios request action using `MempoolM` mkOgmiosRequest :: forall (request :: Type) (response :: Type) . JsonRpc2.JsonRpc2Call request response -> (OgmiosListeners -> ListenerSet request response) -> request - -> QueryM response + -> MempoolM response mkOgmiosRequest jsonRpc2Call getLs inp = do - listeners' <- asks $ listeners <<< _.ogmiosWs <<< _.runtime - websocket <- asks $ underlyingWebSocket <<< _.ogmiosWs <<< _.runtime + listeners' <- asks $ listeners <<< _.ogmiosWs + websocket <- asks $ underlyingWebSocket <<< _.ogmiosWs mkRequest listeners' websocket jsonRpc2Call getLs inp mkRequest @@ -177,14 +187,14 @@ mkRequest -> JsonRpc2.JsonRpc2Call request response -> (listeners -> ListenerSet request response) -> request - -> QueryM response + -> MempoolM response mkRequest listeners' ws jsonRpc2Call getLs inp = do logger <- getLogger liftAff $ mkRequestAff listeners' ws logger jsonRpc2Call getLs inp where - getLogger :: QueryM Logger + getLogger :: MempoolM Logger getLogger = do - logLevel <- asks $ _.config >>> _.logLevel - mbCustomLogger <- asks $ _.config >>> _.customLogger + logLevel <- asks $ _.logLevel + mbCustomLogger <- asks $ _.customLogger pure $ mkLogger logLevel mbCustomLogger diff --git a/src/Internal/Contract/Monad.purs b/src/Internal/Contract/Monad.purs index d8c3699a2a..e95b8e806b 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -56,20 +56,11 @@ import Ctl.Internal.Contract.ProviderBackend import Ctl.Internal.Helpers (filterMapWithKeyM, liftM, logWithLevel) import Ctl.Internal.Logging (Logger, mkLogger, setupLogs) import Ctl.Internal.QueryM (QueryEnv, QueryM) -import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) import Ctl.Internal.QueryM.Ogmios (getProtocolParameters, getSystemStartTime) -import Ctl.Internal.QueryM.Ogmios.JsWebSocket (_wsClose, _wsFinalize) -import Ctl.Internal.QueryM.Ogmios.Mempool - ( WebSocket - , mkOgmiosWebSocketAff - , underlyingWebSocket - ) import Ctl.Internal.QueryM.Ogmios.Types ( OgmiosDecodeError , pprintOgmiosDecodeError ) -import Ctl.Internal.QueryM.UniqueId (uniqueId) -import Ctl.Internal.ServerConfig (mkWsUrl) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM @@ -81,7 +72,7 @@ import Ctl.Internal.Types.UsedTxOuts (UsedTxOuts, isTxOutRefUsed, newUsedTxOuts) import Ctl.Internal.Wallet (Wallet(GenericCip30)) import Ctl.Internal.Wallet.Spec (WalletSpec, mkWalletBySpec) import Data.Bifunctor (lmap) -import Data.Either (Either(Left, Right), isRight) +import Data.Either (Either(Right, Left)) import Data.Log.Level (LogLevel) import Data.Log.Message (Message) import Data.Maybe (Maybe(Just, Nothing), fromMaybe) @@ -89,8 +80,7 @@ import Data.Newtype (class Newtype, unwrap) import Data.Set (Set) import Data.Set as Set import Data.Time.Duration (Milliseconds, Seconds) -import Data.Traversable (for_, traverse, traverse_) -import Effect (Effect) +import Data.Traversable (for_, traverse) import Effect.Aff (Aff, ParAff, attempt, error, finally, supervise) import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Class (class MonadEffect, liftEffect) @@ -266,7 +256,7 @@ mkContractEnv params = do } buildBackend :: Logger -> ProviderBackendParams -> Aff ProviderBackend -buildBackend logger = case _ of +buildBackend _ = case _ of CtlBackendParams ctlParams blockfrostParams -> flip CtlBackend blockfrostParams <$> buildCtlBackend ctlParams BlockfrostBackendParams blockfrostParams ctlParams -> @@ -274,14 +264,8 @@ buildBackend logger = case _ of where buildCtlBackend :: CtlBackendParams -> Aff CtlBackend buildCtlBackend { ogmiosConfig, kupoConfig } = do - let isTxConfirmed = map isRight <<< isTxConfirmedAff kupoConfig - ogmiosWs <- mkOgmiosWebSocketAff uniqueId isTxConfirmed logger - (mkWsUrl ogmiosConfig) pure - { ogmios: - { config: ogmiosConfig - , ws: ogmiosWs - } + { ogmiosConfig , kupoConfig } @@ -366,15 +350,7 @@ walletNetworkCheck envNetworkId = -- | Finalizes a `Contract` environment. -- | Closes the connections in `ContractEnv`, effectively making it unusable. stopContractEnv :: ContractEnv -> Aff Unit -stopContractEnv { backend } = - liftEffect $ traverse_ stopCtlRuntime (getCtlBackend backend) - where - stopCtlRuntime :: CtlBackend -> Effect Unit - stopCtlRuntime { ogmios } = - stopWebSocket ogmios.ws - - stopWebSocket :: forall (a :: Type). WebSocket a -> Effect Unit - stopWebSocket = ((*>) <$> _wsFinalize <*> _wsClose) <<< underlyingWebSocket +stopContractEnv _ = pure unit -- | Constructs and finalizes a contract environment that is usable inside a -- | bracket callback. @@ -482,15 +458,12 @@ mkQueryEnv :: forall (rest :: Row Type). LogParams rest -> CtlBackend -> QueryEnv mkQueryEnv params ctlBackend = { config: - { ogmiosConfig: ctlBackend.ogmios.config + { ogmiosConfig: ctlBackend.ogmiosConfig , kupoConfig: ctlBackend.kupoConfig , logLevel: params.logLevel , customLogger: params.customLogger , suppressLogs: params.suppressLogs } - , runtime: - { ogmiosWs: ctlBackend.ogmios.ws - } } -------------------------------------------------------------------------------- diff --git a/src/Internal/Contract/ProviderBackend.purs b/src/Internal/Contract/ProviderBackend.purs index 5cba5c568b..417a1c04ce 100644 --- a/src/Internal/Contract/ProviderBackend.purs +++ b/src/Internal/Contract/ProviderBackend.purs @@ -15,7 +15,6 @@ module Ctl.Internal.Contract.ProviderBackend import Prelude -import Ctl.Internal.QueryM.Ogmios.Mempool (OgmiosWebSocket) import Ctl.Internal.ServerConfig (ServerConfig) import Data.Maybe (Maybe(Just, Nothing)) import Data.Time.Duration (Seconds(Seconds)) @@ -29,10 +28,7 @@ data ProviderBackend | BlockfrostBackend BlockfrostBackend (Maybe CtlBackend) type CtlBackend = - { ogmios :: - { config :: ServerConfig - , ws :: OgmiosWebSocket - } + { ogmiosConfig :: ServerConfig , kupoConfig :: ServerConfig } diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index defc66e332..4ee3ea0ff8 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -30,7 +30,6 @@ import Control.Parallel (class Parallel, parallel, sequential) import Control.Plus (class Plus) import Ctl.Internal.Helpers (logWithLevel) import Ctl.Internal.QueryM.HttpUtils (handleAffjaxResponseGeneric) -import Ctl.Internal.QueryM.Ogmios.QueryEnv (QueryRuntime) import Ctl.Internal.ServerConfig (ServerConfig) import Data.Either (Either) import Data.Log.Level (LogLevel) @@ -72,7 +71,6 @@ type QueryConfig = -- | `QueryEnv` contains everything needed for `QueryM` to run. type QueryEnv = { config :: QueryConfig - , runtime :: QueryRuntime } type QueryM = QueryMT Aff diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.js b/src/Internal/QueryM/Ogmios/JsonRpc2.js new file mode 100644 index 0000000000..a96dee7ac8 --- /dev/null +++ b/src/Internal/QueryM/Ogmios/JsonRpc2.js @@ -0,0 +1,5 @@ +import uniqid from "uniqid"; + +export function uniqueId(str) { + return () => uniqid(str); +} diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/JsonRpc2.purs index e2de0b3339..e2ffb77afc 100644 --- a/src/Internal/QueryM/Ogmios/JsonRpc2.purs +++ b/src/Internal/QueryM/Ogmios/JsonRpc2.purs @@ -16,6 +16,9 @@ import Data.Either (Either) import Effect (Effect) import Record as Record +-- | Creates a unique id prefixed by its argument +foreign import uniqueId :: String -> Effect String + -- | Structure of all json rpc2.0 websocket requests -- described in: https://ogmios.dev/getting-started/basics/ type JsonRpc2Request (a :: Type) = @@ -28,13 +31,12 @@ type JsonRpc2Request (a :: Type) = -- | Convenience helper function for creating `JsonRpc2Request a` objects mkJsonRpc2Request :: forall (a :: Type) - . (String -> Effect String) - -> { jsonrpc :: String } + . { jsonrpc :: String } -> { method :: String , params :: a } -> Effect (JsonRpc2Request a) -mkJsonRpc2Request uniqueId service method = do +mkJsonRpc2Request service method = do id <- uniqueId $ method.method <> "-" pure $ Record.merge { id } @@ -50,12 +52,11 @@ newtype JsonRpc2Call (i :: Type) (o :: Type) = JsonRpc2Call mkCallType :: forall (a :: Type) (i :: Type) (o :: Type) . EncodeAeson (JsonRpc2Request a) - => (String -> Effect String) - -> { jsonrpc :: String } + => { jsonrpc :: String } -> { method :: String, params :: i -> a } -> JsonRpc2Call i o -mkCallType uniqueId service { method, params } = JsonRpc2Call \i -> do - req <- mkJsonRpc2Request uniqueId service { method, params: params i } +mkCallType service { method, params } = JsonRpc2Call \i -> do + req <- mkJsonRpc2Request service { method, params: params i } pure { body: encodeAeson req, id: req.id } -- | Create a JsonRpc2 request body and id diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index cd90fe314d..b891fdcc42 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -102,7 +102,6 @@ import Effect.Exception (Error, error) import Effect.Ref as Ref type ListenerId = String -type MkUniqueId = (String -> Effect String) type Logger = LogLevel -> String -> Effect Unit @@ -111,68 +110,63 @@ type Logger = LogLevel -> String -> Effect Unit -------------------------------------------------------------------------------- acquireMempoolSnapshotAff - :: MkUniqueId -> OgmiosWebSocket -> Logger -> Aff MempoolSnapshotAcquired -acquireMempoolSnapshotAff u ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger (acquireMempoolSnapshotCall u) + :: OgmiosWebSocket -> Logger -> Aff MempoolSnapshotAcquired +acquireMempoolSnapshotAff ogmiosWs logger = + mkOgmiosRequestAff ogmiosWs logger acquireMempoolSnapshotCall _.acquireMempool unit mempoolSnapshotHasTxAff - :: MkUniqueId - -> OgmiosWebSocket + :: OgmiosWebSocket -> Logger -> MempoolSnapshotAcquired -> TransactionHash -> Aff Boolean -mempoolSnapshotHasTxAff u ogmiosWs logger ms txh = +mempoolSnapshotHasTxAff ogmiosWs logger ms txh = unwrap <$> mkOgmiosRequestAff ogmiosWs logger - (mempoolSnapshotHasTxCall u ms) + (mempoolSnapshotHasTxCall ms) _.mempoolHasTx txh acquireMempoolSnapshotCall - :: MkUniqueId -> JsonRpc2Call Unit MempoolSnapshotAcquired -acquireMempoolSnapshotCall u = - mkOgmiosCallTypeNoArgs u "acquireMempool" + :: JsonRpc2Call Unit MempoolSnapshotAcquired +acquireMempoolSnapshotCall = + mkOgmiosCallTypeNoArgs "acquireMempool" mempoolSnapshotHasTxCall - :: MkUniqueId - -> MempoolSnapshotAcquired + :: MempoolSnapshotAcquired -> JsonRpc2Call TransactionHash HasTxR -mempoolSnapshotHasTxCall u _ = mkOgmiosCallType u +mempoolSnapshotHasTxCall _ = mkOgmiosCallType { method: "hasTransaction" , params: { id: _ } } mempoolSnapshotNextTxCall - :: MkUniqueId - -> MempoolSnapshotAcquired + :: MempoolSnapshotAcquired -> JsonRpc2Call Unit MaybeMempoolTransaction -mempoolSnapshotNextTxCall u _ = mkOgmiosCallType u +mempoolSnapshotNextTxCall _ = mkOgmiosCallType { method: "nextTransaction" , params: const { fields: "all" } } mempoolSnapshotSizeAndCapacityCall - :: MkUniqueId - -> MempoolSnapshotAcquired + :: MempoolSnapshotAcquired -> JsonRpc2Call Unit MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityCall u _ = - mkOgmiosCallTypeNoArgs u "sizeOfMempool" +mempoolSnapshotSizeAndCapacityCall _ = + mkOgmiosCallTypeNoArgs "sizeOfMempool" releaseMempoolCall - :: MkUniqueId -> MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool -releaseMempoolCall u _ = - mkOgmiosCallTypeNoArgs u "releaseMempool" + :: MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool +releaseMempoolCall _ = + mkOgmiosCallTypeNoArgs "releaseMempool" withMempoolSnapshot - :: MkUniqueId - -> OgmiosWebSocket + :: OgmiosWebSocket -> Logger -> (Maybe MempoolSnapshotAcquired -> Aff Unit) -> Effect Unit -withMempoolSnapshot u ogmiosWs logger cont = - flip runAff_ (acquireMempoolSnapshotAff u ogmiosWs logger) $ case _ of +withMempoolSnapshot ogmiosWs logger cont = + flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of Left err -> do logger Error $ "Failed to acquire a mempool snapshot: Error: " <> show err @@ -187,21 +181,19 @@ withMempoolSnapshot u ogmiosWs logger cont = mkOgmiosCallTypeNoArgs :: forall (o :: Type) . DecodeOgmios o - => MkUniqueId - -> String + => String -> JsonRpc2Call Unit o -mkOgmiosCallTypeNoArgs u method = - mkOgmiosCallType u { method, params: const {} } +mkOgmiosCallTypeNoArgs method = + mkOgmiosCallType { method, params: const {} } mkOgmiosCallType :: forall (a :: Type) (i :: Type) (o :: Type) . EncodeAeson (JsonRpc2Request a) => DecodeOgmios o - => MkUniqueId - -> { method :: String, params :: i -> a } + => { method :: String, params :: i -> a } -> JsonRpc2Call i o -mkOgmiosCallType u = - mkCallType u { jsonrpc: "2.0" } +mkOgmiosCallType = + mkCallType { jsonrpc: "2.0" } -------------------------------------------------------------------------------- -- WebSocket @@ -232,13 +224,12 @@ listeners (WebSocket _ ls) = ls type IsTxConfirmed = TransactionHash -> Aff Boolean mkOgmiosWebSocketAff - :: MkUniqueId - -> IsTxConfirmed + :: IsTxConfirmed -> Logger -> String -> Aff OgmiosWebSocket -mkOgmiosWebSocketAff u isTxConfirmed logger serverUrl = do - lens <- liftEffect $ mkOgmiosWebSocketLens u logger isTxConfirmed +mkOgmiosWebSocketAff isTxConfirmed logger serverUrl = do + lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed makeAff $ mkServiceWebSocket lens serverUrl mkServiceWebSocket @@ -296,8 +287,7 @@ mkServiceWebSocket lens url continue = do -- | been added to the mempool or has been included in a block before retrying -- | the request. resendPendingSubmitRequests - :: MkUniqueId - -> OgmiosWebSocket + :: OgmiosWebSocket -> IsTxConfirmed -> Logger -> (RequestBody -> Effect Unit) @@ -305,7 +295,6 @@ resendPendingSubmitRequests -> PendingSubmitTxRequests -> Effect Unit resendPendingSubmitRequests - u ogmiosWs isTxConfirmed logger @@ -316,7 +305,7 @@ resendPendingSubmitRequests unless (Map.isEmpty submitTxPendingRequests) do -- Acquiring a mempool snapshot should never fail and, -- after ws reconnection, should be instantaneous. - withMempoolSnapshot u ogmiosWs logger case _ of + withMempoolSnapshot ogmiosWs logger case _ of Nothing -> liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests Just ms -> do @@ -340,7 +329,7 @@ resendPendingSubmitRequests -> Aff Unit handlePendingSubmitRequest ms listenerId requestBody txHash = do -- Check if the transaction was added to the mempool: - txInMempool <- mempoolSnapshotHasTxAff u ogmiosWs logger ms txHash + txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash log "Tx in the mempool" txInMempool txHash retrySubmitTx <- if txInMempool then pure false @@ -376,11 +365,10 @@ type MkServiceWebSocketLens (listeners :: Type) = } mkOgmiosWebSocketLens - :: MkUniqueId - -> Logger + :: Logger -> IsTxConfirmed -> Effect (MkServiceWebSocketLens OgmiosListeners) -mkOgmiosWebSocketLens u logger isTxConfirmed = do +mkOgmiosWebSocketLens logger isTxConfirmed = do dispatcher <- newDispatcher pendingRequests <- newPendingRequests pendingSubmitTxRequests <- newPendingRequests @@ -404,7 +392,7 @@ mkOgmiosWebSocketLens u logger isTxConfirmed = do resendPendingRequests ws = do let sendRequest = _wsSend ws (logger Debug) Ref.read pendingRequests >>= traverse_ sendRequest - resendPendingSubmitRequests u (ogmiosWebSocket ws) isTxConfirmed + resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed logger sendRequest dispatcher @@ -676,3 +664,4 @@ instance DecodeAeson ReleasedMempool where instance DecodeOgmios ReleasedMempool where decodeOgmios = decodeResult decodeAeson + diff --git a/src/Internal/QueryM/Ogmios/QueryEnv.purs b/src/Internal/QueryM/Ogmios/QueryEnv.purs deleted file mode 100644 index 33b6799530..0000000000 --- a/src/Internal/QueryM/Ogmios/QueryEnv.purs +++ /dev/null @@ -1,15 +0,0 @@ -module Ctl.Internal.QueryM.Ogmios.QueryEnv - ( QueryRuntime - ) where - -import Ctl.Internal.QueryM.Ogmios.Mempool (OgmiosWebSocket) - --- | Reusable part of `QueryRuntime` that can be shared between many `QueryM` --- | instances running in parallel. --- | --- | Includes: --- | - WebSocket connections -type QueryRuntime = - { ogmiosWs :: OgmiosWebSocket - } - diff --git a/src/Internal/Test/E2E/Runner.purs b/src/Internal/Test/E2E/Runner.purs index 81012a63fe..44f1a03717 100644 --- a/src/Internal/Test/E2E/Runner.purs +++ b/src/Internal/Test/E2E/Runner.purs @@ -262,7 +262,7 @@ testPlan opts@{ tests } rt@{ wallets } = kwMStakeKey <- liftAff $ getPrivateStakeKey wallet (clusterSetup :: ClusterSetup) <- case env.backend of CtlBackend backend _ -> pure - { ogmiosConfig: backend.ogmios.config + { ogmiosConfig: backend.ogmiosConfig , kupoConfig: backend.kupoConfig , keys: { payment: kwPaymentKey diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index 8c3740b15e..80dac1dfc7 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -29,7 +29,6 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , mkRequestAff ) import Ctl.Internal.QueryM.Ogmios.Types (class DecodeOgmios) -import Ctl.Internal.QueryM.UniqueId (uniqueId) import Ctl.Internal.ServerConfig (ServerConfig, defaultOgmiosWsConfig, mkWsUrl) import Data.Either (Either(Left, Right)) import Data.Log.Level (LogLevel(Trace, Debug)) @@ -104,7 +103,7 @@ instance DecodeOgmios AesonResponse where mkQueryWithArgs' :: forall a. EncodeAeson a => String -> a -> Query mkQueryWithArgs' method a = Query - (mkOgmiosCallType uniqueId { method, params: identity }) + (mkOgmiosCallType { method, params: identity }) (sanitiseMethod method) (encodeAeson a) diff --git a/test/Testnet.purs b/test/Testnet.purs index ad5fe4720e..dd0ef5c374 100644 --- a/test/Testnet.purs +++ b/test/Testnet.purs @@ -4,14 +4,8 @@ module Test.Ctl.Testnet import Prelude -import Contract.Test (noWallet) -import Contract.Test.Testnet - ( defaultTestnetConfig - , runTestnetTestPlan - , testTestnetContracts - ) +import Contract.Test.Testnet (defaultTestnetConfig, testTestnetContracts) import Contract.Test.Utils (exitCode, interruptOnSignal) -import Ctl.Internal.Contract.Monad (wrapQueryM) import Data.Maybe (Maybe(Just)) import Data.Posix.Signal (Signal(SIGINT)) import Effect (Effect) @@ -22,19 +16,8 @@ import Effect.Aff , launchAff ) import Mote (group) -import Mote.Monad (mapTest) import Mote.TestPlanM as Utils -import Test.Ctl.BalanceTx.ChangeGeneration as ChangeGeneration -import Test.Ctl.QueryM.AffInterface as QueryM.AffInterface -import Test.Ctl.Testnet.Contract as Contract -import Test.Ctl.Testnet.Contract.Assert as Assert -import Test.Ctl.Testnet.Contract.Mnemonics as Mnemonics import Test.Ctl.Testnet.Contract.OgmiosMempool as OgmiosMempool -import Test.Ctl.Testnet.ExUnits as ExUnits -import Test.Ctl.Testnet.Gov as Gov -import Test.Ctl.Testnet.Logging as Logging -import Test.Ctl.Testnet.SameWallets as SameWallets -import Test.Ctl.Testnet.UtxoDistribution as UtxoDistribution import Test.Spec.Runner (defaultConfig) -- Run with `npm run testnet-test` @@ -45,24 +28,7 @@ main = interruptOnSignal SIGINT =<< launchAff do Utils.interpretWithConfig defaultConfig { timeout = Just $ Milliseconds 70_000.0, exit = true } $ group "cardano-testnet" do - testTestnetContracts config Mnemonics.suite - group "ExUnits - normal limits" do - testTestnetContracts config $ ExUnits.mkFailingSuite 8000 - testTestnetContracts config $ ExUnits.mkSuite 2550 - -- FIXME: group "ExUnits - relaxed limits" do - -- testTestnetContracts configWithMaxExUnits $ ExUnits.mkSuite 3000 - testTestnetContracts config Assert.suite - Logging.suite - -- FIXME: testStartPlutipCluster - testTestnetContracts config $ do - flip mapTest QueryM.AffInterface.suite - (noWallet <<< wrapQueryM) - ChangeGeneration.suite - Contract.suite - Gov.suite - UtxoDistribution.suite testTestnetContracts config OgmiosMempool.suite - runTestnetTestPlan config SameWallets.suite -- FIXME: ClusterParameters.runTest {- diff --git a/test/Testnet/Contract/OgmiosMempool.purs b/test/Testnet/Contract/OgmiosMempool.purs index c3b315b598..7f50855fee 100644 --- a/test/Testnet/Contract/OgmiosMempool.purs +++ b/test/Testnet/Contract/OgmiosMempool.purs @@ -7,23 +7,56 @@ import Prelude import Cardano.Types.BigNum as BigNum import Cardano.Types.PlutusScript (hash) as PlutusScript import Contract.Backend.Ogmios.Mempool - ( acquireMempoolSnapshot + ( MempoolM + , acquireMempoolSnapshot , fetchMempoolTxs , mempoolSnapshotHasTx , mempoolSnapshotSizeAndCapacity , withMempoolSnapshot ) +import Contract.Monad (Contract) import Contract.Test (ContractTest, InitialUTxOs, withKeyWallet, withWallets) import Contract.Test.Mote (TestPlanM) import Contract.Transaction (awaitTxConfirmed) +import Control.Monad.Except.Trans (throwError) +import Control.Monad.Reader.Trans (ask, runReaderT) import Ctl.Examples.PlutusV2.InlineDatum as InlineDatum +import Ctl.Internal.Contract.ProviderBackend (ProviderBackend(CtlBackend)) +import Ctl.Internal.Logging (mkLogger) import Ctl.Internal.QueryM.Ogmios.Mempool ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) + , OgmiosWebSocket + , mkOgmiosWebSocketAff ) +import Ctl.Internal.ServerConfig (mkWsUrl) import Data.Array (length) +import Data.Newtype (unwrap) +import Effect.Aff.Class (liftAff) +import Effect.Exception (error) import Mote (group, skip, test) import Test.Spec.Assertions (shouldEqual) +mkWebsocket :: Contract OgmiosWebSocket +mkWebsocket = do + config <- ask + ogmiosConfig <- case config.backend of + CtlBackend ctlBackend _ -> pure ctlBackend.ogmiosConfig + _ -> throwError $ error "Ogmios backend not supported" + liftAff $ mkOgmiosWebSocketAff (const $ pure true) + (mkLogger config.logLevel config.customLogger) + (mkWsUrl ogmiosConfig) + +runMempoolAction + :: forall (a :: Type). OgmiosWebSocket -> MempoolM a -> Contract a +runMempoolAction ogmiosWs mempoolAction = do + config <- ask + liftAff $ runReaderT (unwrap mempoolAction) + { ogmiosWs + , logLevel: config.logLevel + , customLogger: config.customLogger + , suppressLogs: config.suppressLogs + } + suite :: TestPlanM ContractTest Unit suite = group "Ogmios mempool test" do test "acquireMempoolSnapshot" do @@ -35,7 +68,9 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do - void acquireMempoolSnapshot + ws <- mkWebsocket + void $ runMempoolAction ws acquireMempoolSnapshot + test "fetchMempoolTXs" do let distribution :: InitialUTxOs @@ -45,13 +80,16 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do + ws <- mkWebsocket validator <- InlineDatum.checkDatumIsInlineScript let vhash = PlutusScript.hash validator txId <- InlineDatum.payToCheckDatumIsInline vhash - mpTxs <- fetchMempoolTxs =<< acquireMempoolSnapshot + mpTxs <- runMempoolAction ws + (fetchMempoolTxs =<< acquireMempoolSnapshot) length mpTxs `shouldEqual` 1 awaitTxConfirmed txId - mpTxs' <- fetchMempoolTxs =<< acquireMempoolSnapshot + mpTxs' <- runMempoolAction ws + (fetchMempoolTxs =<< acquireMempoolSnapshot) length mpTxs' `shouldEqual` 0 skip $ test "mempoolSnapshotHasTx - skipped because HasTx always returns false for some reason" @@ -64,18 +102,21 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do + ws <- mkWebsocket validator <- InlineDatum.checkDatumIsInlineScript let vhash = PlutusScript.hash validator txId <- InlineDatum.payToCheckDatumIsInline vhash - withMempoolSnapshot (flip mempoolSnapshotHasTx txId) >>= shouldEqual - true - snapshot <- acquireMempoolSnapshot - _mpTxs' <- fetchMempoolTxs snapshot + runMempoolAction ws $ + withMempoolSnapshot (flip mempoolSnapshotHasTx txId) >>= shouldEqual + true + snapshot <- runMempoolAction ws acquireMempoolSnapshot + _mpTxs' <- runMempoolAction ws $ fetchMempoolTxs snapshot -- for_ mpTxs' \tx -> do -- liftEffect <<< Console.log <<< show =<< liftEffect -- (transactionHash tx) awaitTxConfirmed txId - mempoolSnapshotHasTx snapshot txId >>= shouldEqual false + runMempoolAction ws $ + mempoolSnapshotHasTx snapshot txId >>= shouldEqual false test "mempoolSnapshotSizeAndCapacity" do let distribution :: InitialUTxOs @@ -85,9 +126,11 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do + ws <- mkWebsocket validator <- InlineDatum.checkDatumIsInlineScript let vhash = PlutusScript.hash validator void $ InlineDatum.payToCheckDatumIsInline vhash MempoolSizeAndCapacity { numberOfTxs } <- - withMempoolSnapshot (mempoolSnapshotSizeAndCapacity) + runMempoolAction ws $ withMempoolSnapshot + (mempoolSnapshotSizeAndCapacity) numberOfTxs `shouldEqual` 1 From 06a5955e1c31508b4f2e26126fba830d152cc807 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Thu, 13 Feb 2025 20:50:28 -0300 Subject: [PATCH 21/27] Refactor mempool code structure --- src/Contract/Backend/Ogmios/Mempool.purs | 4 ++-- src/Internal/QueryM/Ogmios/Mempool.purs | 8 +++---- .../Ogmios/{ => Mempool}/Dispatcher.purs | 4 ++-- .../Ogmios/{ => Mempool}/JsWebSocket.js | 0 .../Ogmios/{ => Mempool}/JsWebSocket.purs | 2 +- .../QueryM/Ogmios/{ => Mempool}/JsonRpc2.js | 0 .../QueryM/Ogmios/{ => Mempool}/JsonRpc2.purs | 2 +- test/Ogmios/GenerateFixtures.purs | 22 +++++++++---------- 8 files changed, 21 insertions(+), 21 deletions(-) rename src/Internal/QueryM/Ogmios/{ => Mempool}/Dispatcher.purs (95%) rename src/Internal/QueryM/Ogmios/{ => Mempool}/JsWebSocket.js (100%) rename src/Internal/QueryM/Ogmios/{ => Mempool}/JsWebSocket.purs (96%) rename src/Internal/QueryM/Ogmios/{ => Mempool}/JsonRpc2.js (100%) rename src/Internal/QueryM/Ogmios/{ => Mempool}/JsonRpc2.purs (97%) diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index aa373406f7..b2ae592998 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -28,8 +28,6 @@ import Control.Monad.Error.Class import Control.Monad.Reader.Class (class MonadAsk) import Control.Monad.Reader.Trans (ReaderT(ReaderT), asks) import Ctl.Internal.Logging (Logger, mkLogger) -import Ctl.Internal.QueryM.Ogmios.JsWebSocket (JsWebSocket) -import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , OgmiosListeners @@ -48,6 +46,8 @@ import Ctl.Internal.QueryM.Ogmios.Mempool , MempoolSnapshotAcquired , MempoolTransaction(MempoolTransaction) ) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket (JsWebSocket) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 as JsonRpc2 import Data.Array as Array import Data.ByteArray (hexToByteArray) import Data.List (List(Cons)) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index b891fdcc42..053dfd9a46 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -43,7 +43,7 @@ import Cardano.Types.Slot (Slot) import Cardano.Types.TransactionHash (TransactionHash) import Control.Alt ((<|>)) import Control.Monad.Error.Class (liftEither, throwError) -import Ctl.Internal.QueryM.Ogmios.Dispatcher +import Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher ( DispatchError(JsonError) , Dispatcher , GenericPendingRequests @@ -55,7 +55,7 @@ import Ctl.Internal.QueryM.Ogmios.Dispatcher , newDispatcher , newPendingRequests ) -import Ctl.Internal.QueryM.Ogmios.JsWebSocket +import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket ( JsWebSocket , Url , _mkWebSocket @@ -67,12 +67,12 @@ import Ctl.Internal.QueryM.Ogmios.JsWebSocket , _wsFinalize , _wsSend ) -import Ctl.Internal.QueryM.Ogmios.JsonRpc2 +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 ( JsonRpc2Call , JsonRpc2Request , mkCallType ) -import Ctl.Internal.QueryM.Ogmios.JsonRpc2 as JsonRpc2 +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 as JsonRpc2 import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios , OgmiosDecodeError diff --git a/src/Internal/QueryM/Ogmios/Dispatcher.purs b/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs similarity index 95% rename from src/Internal/QueryM/Ogmios/Dispatcher.purs rename to src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs index 6a2a809188..6a96808e7c 100644 --- a/src/Internal/QueryM/Ogmios/Dispatcher.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.Ogmios.Dispatcher +module Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher ( DispatchError(JsonError, FaultError, ListenerCancelled) , Dispatcher , GenericPendingRequests @@ -17,7 +17,7 @@ import Prelude import Aeson (Aeson, JsonDecodeError, stringifyAeson) import Cardano.Types.TransactionHash (TransactionHash) -import Ctl.Internal.QueryM.Ogmios.JsonRpc2 (parseJsonRpc2ResponseId) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 (parseJsonRpc2ResponseId) import Data.Either (Either(Left, Right)) import Data.Map (Map) import Data.Map (empty, lookup) as Map diff --git a/src/Internal/QueryM/Ogmios/JsWebSocket.js b/src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.js similarity index 100% rename from src/Internal/QueryM/Ogmios/JsWebSocket.js rename to src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.js diff --git a/src/Internal/QueryM/Ogmios/JsWebSocket.purs b/src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.purs similarity index 96% rename from src/Internal/QueryM/Ogmios/JsWebSocket.purs rename to src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.purs index bd06252288..936d1abcba 100644 --- a/src/Internal/QueryM/Ogmios/JsWebSocket.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.QueryM.Ogmios.JsWebSocket +module Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket ( JsWebSocket , ListenerRef , Url diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.js b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.js similarity index 100% rename from src/Internal/QueryM/Ogmios/JsonRpc2.js rename to src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.js diff --git a/src/Internal/QueryM/Ogmios/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs similarity index 97% rename from src/Internal/QueryM/Ogmios/JsonRpc2.purs rename to src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs index e2ffb77afc..59209ec6f4 100644 --- a/src/Internal/QueryM/Ogmios/JsonRpc2.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs @@ -1,6 +1,6 @@ -- | Provides basics types and operations for working with JSON RPC protocol -- | used by Ogmios -module Ctl.Internal.QueryM.Ogmios.JsonRpc2 +module Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 ( JsonRpc2Call , JsonRpc2Request , buildRequest diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index 80dac1dfc7..ca03a96b8b 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -7,11 +7,19 @@ import Prelude import Aeson (class EncodeAeson, Aeson, encodeAeson, stringifyAeson) import Control.Parallel (parTraverse) import Ctl.Internal.Helpers (logString) -import Ctl.Internal.QueryM.Ogmios.Dispatcher +import Ctl.Internal.QueryM.Ogmios.Mempool + ( ListenerSet + , WebSocket(WebSocket) + , defaultMessageListener + , mkListenerSet + , mkOgmiosCallType + , mkRequestAff + ) +import Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher ( WebsocketDispatch , mkWebsocketDispatch ) -import Ctl.Internal.QueryM.Ogmios.JsWebSocket +import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket ( _mkWebSocket , _onWsConnect , _onWsError @@ -19,15 +27,7 @@ import Ctl.Internal.QueryM.Ogmios.JsWebSocket , _wsClose , _wsSend ) -import Ctl.Internal.QueryM.Ogmios.JsonRpc2 (JsonRpc2Call) -import Ctl.Internal.QueryM.Ogmios.Mempool - ( ListenerSet - , WebSocket(WebSocket) - , defaultMessageListener - , mkListenerSet - , mkOgmiosCallType - , mkRequestAff - ) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 (JsonRpc2Call) import Ctl.Internal.QueryM.Ogmios.Types (class DecodeOgmios) import Ctl.Internal.ServerConfig (ServerConfig, defaultOgmiosWsConfig, mkWsUrl) import Data.Either (Either(Left, Right)) From 99b98a0f3446c04f586f2bd287f9d8dc24560a61 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Thu, 13 Feb 2025 20:54:15 -0300 Subject: [PATCH 22/27] Remove `resendPendingSubmitRequests` in websocket internals --- src/Internal/QueryM/Ogmios/Mempool.purs | 153 ++--------------------- test/Testnet/Contract/OgmiosMempool.purs | 2 +- 2 files changed, 8 insertions(+), 147 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index 053dfd9a46..92f19ba3e1 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -32,7 +32,6 @@ import Aeson , Aeson , JsonDecodeError(UnexpectedValue, TypeMismatch) , decodeAeson - , encodeAeson , getField , parseJsonStringToAeson , stringifyAeson @@ -48,7 +47,6 @@ import Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher , Dispatcher , GenericPendingRequests , PendingRequests - , PendingSubmitTxRequests , RequestBody , WebsocketDispatch , mkWebsocketDispatch @@ -79,7 +77,6 @@ import Ctl.Internal.QueryM.Ogmios.Types , decodeOgmios , decodeResult , ogmiosDecodeErrorToError - , submitSuccessPartialResp ) import Ctl.Internal.Service.Helpers (aesonNull, aesonObject, aesonString) import Data.Argonaut.Encode.Encoders as Argonaut @@ -89,14 +86,12 @@ import Data.Foldable (foldl) import Data.Generic.Rep (class Generic) import Data.Log.Level (LogLevel(Error, Debug)) import Data.Map as Map -import Data.Maybe (Maybe(Just, Nothing), maybe) -import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Maybe (Maybe(Nothing, Just)) +import Data.Newtype (class Newtype, wrap) import Data.Show.Generic (genericShow) -import Data.Traversable (for_, traverse_) -import Data.Tuple (fst) import Data.Tuple.Nested (type (/\), (/\)) import Effect (Effect) -import Effect.Aff (Aff, Canceler(Canceler), delay, launchAff_, makeAff, runAff_) +import Effect.Aff (Aff, Canceler(Canceler), makeAff) import Effect.Class (liftEffect) import Effect.Exception (Error, error) import Effect.Ref as Ref @@ -109,25 +104,6 @@ type Logger = LogLevel -> String -> Effect Unit -- Ogmios Local Tx Monitor Protocol -------------------------------------------------------------------------------- -acquireMempoolSnapshotAff - :: OgmiosWebSocket -> Logger -> Aff MempoolSnapshotAcquired -acquireMempoolSnapshotAff ogmiosWs logger = - mkOgmiosRequestAff ogmiosWs logger acquireMempoolSnapshotCall - _.acquireMempool - unit - -mempoolSnapshotHasTxAff - :: OgmiosWebSocket - -> Logger - -> MempoolSnapshotAcquired - -> TransactionHash - -> Aff Boolean -mempoolSnapshotHasTxAff ogmiosWs logger ms txh = - unwrap <$> mkOgmiosRequestAff ogmiosWs logger - (mempoolSnapshotHasTxCall ms) - _.mempoolHasTx - txh - acquireMempoolSnapshotCall :: JsonRpc2Call Unit MempoolSnapshotAcquired acquireMempoolSnapshotCall = @@ -160,20 +136,6 @@ releaseMempoolCall releaseMempoolCall _ = mkOgmiosCallTypeNoArgs "releaseMempool" -withMempoolSnapshot - :: OgmiosWebSocket - -> Logger - -> (Maybe MempoolSnapshotAcquired -> Aff Unit) - -> Effect Unit -withMempoolSnapshot ogmiosWs logger cont = - flip runAff_ (acquireMempoolSnapshotAff ogmiosWs logger) $ case _ of - Left err -> do - logger Error $ - "Failed to acquire a mempool snapshot: Error: " <> show err - launchAff_ (cont Nothing) - Right mempoolSnapshot -> - launchAff_ (cont $ Just mempoolSnapshot) - -------------------------------------------------------------------------------- -- Helpers -------------------------------------------------------------------------------- @@ -224,12 +186,11 @@ listeners (WebSocket _ ls) = ls type IsTxConfirmed = TransactionHash -> Aff Boolean mkOgmiosWebSocketAff - :: IsTxConfirmed - -> Logger + :: Logger -> String -> Aff OgmiosWebSocket -mkOgmiosWebSocketAff isTxConfirmed logger serverUrl = do - lens <- liftEffect $ mkOgmiosWebSocketLens logger isTxConfirmed +mkOgmiosWebSocketAff logger serverUrl = do + lens <- liftEffect $ mkOgmiosWebSocketLens logger makeAff $ mkServiceWebSocket lens serverUrl mkServiceWebSocket @@ -262,7 +223,6 @@ mkServiceWebSocket lens url continue = do lens.logger Debug $ lens.serviceName <> " WebSocket connection re-established, resending pending requests..." - lens.resendPendingRequests ws false -> do lens.logger Debug $ "Connection to " <> lens.serviceName <> " established" Ref.write true hasConnectedOnceRef @@ -279,79 +239,6 @@ mkServiceWebSocket lens url continue = do _wsClose ws continue $ Left $ err --------------------------------------------------------------------------------- --- Resend pending `SubmitTx` requests --------------------------------------------------------------------------------- - --- | For each pending `SubmitTx` request, checks whether the transaction has --- | been added to the mempool or has been included in a block before retrying --- | the request. -resendPendingSubmitRequests - :: OgmiosWebSocket - -> IsTxConfirmed - -> Logger - -> (RequestBody -> Effect Unit) - -> Dispatcher - -> PendingSubmitTxRequests - -> Effect Unit -resendPendingSubmitRequests - ogmiosWs - isTxConfirmed - logger - sendRequest - dispatcher - pr = do - submitTxPendingRequests <- Ref.read pr - unless (Map.isEmpty submitTxPendingRequests) do - -- Acquiring a mempool snapshot should never fail and, - -- after ws reconnection, should be instantaneous. - withMempoolSnapshot ogmiosWs logger case _ of - Nothing -> - liftEffect $ traverse_ (sendRequest <<< fst) submitTxPendingRequests - Just ms -> do - -- A delay of 5 sec for transactions to be processed by the node - -- and added to the mempool: - delay (wrap 5000.0) - let (pr' :: Array _) = Map.toUnfoldable submitTxPendingRequests - for_ pr' \(listenerId /\ requestBody /\ txHash) -> - handlePendingSubmitRequest ms listenerId requestBody txHash - where - log :: String -> Boolean -> TransactionHash -> Aff Unit - log label value txHash = - liftEffect $ logger Debug $ - label <> ": " <> show value <> " TransactionHash: " <> show txHash - - handlePendingSubmitRequest - :: MempoolSnapshotAcquired - -> ListenerId - -> RequestBody - -> TransactionHash - -> Aff Unit - handlePendingSubmitRequest ms listenerId requestBody txHash = do - -- Check if the transaction was added to the mempool: - txInMempool <- mempoolSnapshotHasTxAff ogmiosWs logger ms txHash - log "Tx in the mempool" txInMempool txHash - retrySubmitTx <- - if txInMempool then pure false - else do - -- Check if the transaction was included in the block: - txConfirmed <- isTxConfirmed txHash - log "Tx confirmed" txConfirmed txHash - unless txConfirmed $ liftEffect do - sendRequest requestBody - pure (not txConfirmed) - -- Manually dispatch `SubmitTx` response if resending is not required: - unless retrySubmitTx $ liftEffect do - Ref.modify_ (Map.delete listenerId) pr - dispatchMap <- Ref.read dispatcher - Ref.modify_ (Map.delete listenerId) dispatcher - Map.lookup listenerId dispatchMap # - maybe (pure unit) (_ $ submitSuccessPartialRespInner) - where - submitSuccessPartialRespInner :: Aeson - submitSuccessPartialRespInner = - encodeAeson $ submitSuccessPartialResp txHash - -------------------------------------------------------------------------------- -- `MkServiceWebSocketLens` for ogmios -------------------------------------------------------------------------------- @@ -361,17 +248,14 @@ type MkServiceWebSocketLens (listeners :: Type) = , dispatcher :: Dispatcher , logger :: Logger , typedWebSocket :: JsWebSocket -> WebSocket listeners - , resendPendingRequests :: JsWebSocket -> Effect Unit } mkOgmiosWebSocketLens :: Logger - -> IsTxConfirmed -> Effect (MkServiceWebSocketLens OgmiosListeners) -mkOgmiosWebSocketLens logger isTxConfirmed = do +mkOgmiosWebSocketLens logger = do dispatcher <- newDispatcher pendingRequests <- newPendingRequests - pendingSubmitTxRequests <- newPendingRequests pure $ let ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket @@ -388,21 +272,11 @@ mkOgmiosWebSocketLens logger isTxConfirmed = do mkListenerSet dispatcher pendingRequests } - resendPendingRequests :: JsWebSocket -> Effect Unit - resendPendingRequests ws = do - let sendRequest = _wsSend ws (logger Debug) - Ref.read pendingRequests >>= traverse_ sendRequest - resendPendingSubmitRequests (ogmiosWebSocket ws) isTxConfirmed - logger - sendRequest - dispatcher - pendingSubmitTxRequests in { serviceName: "ogmios" , dispatcher , logger , typedWebSocket: ogmiosWebSocket - , resendPendingRequests } -------------------------------------------------------------------------------- @@ -472,19 +346,6 @@ mkListenerSet dispatcher pendingRequests = Ref.modify_ (Map.insert reflection requestBody) pendingRequests } --- | Builds an Ogmios request action using `Aff` -mkOgmiosRequestAff - :: forall (request :: Type) (response :: Type) - . OgmiosWebSocket - -> Logger - -> JsonRpc2.JsonRpc2Call request response - -> (OgmiosListeners -> ListenerSet request response) - -> request - -> Aff response -mkOgmiosRequestAff ogmiosWs = mkRequestAff - (listeners ogmiosWs) - (underlyingWebSocket ogmiosWs) - mkRequestAff :: forall (request :: Type) (response :: Type) (listeners :: Type) . listeners diff --git a/test/Testnet/Contract/OgmiosMempool.purs b/test/Testnet/Contract/OgmiosMempool.purs index 7f50855fee..786fb96ed5 100644 --- a/test/Testnet/Contract/OgmiosMempool.purs +++ b/test/Testnet/Contract/OgmiosMempool.purs @@ -42,7 +42,7 @@ mkWebsocket = do ogmiosConfig <- case config.backend of CtlBackend ctlBackend _ -> pure ctlBackend.ogmiosConfig _ -> throwError $ error "Ogmios backend not supported" - liftAff $ mkOgmiosWebSocketAff (const $ pure true) + liftAff $ mkOgmiosWebSocketAff (mkLogger config.logLevel config.customLogger) (mkWsUrl ogmiosConfig) From 946c443c70e4c003b8f14c928791b448e555a156 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Fri, 14 Feb 2025 09:59:19 -0300 Subject: [PATCH 23/27] Remove internal CTL helper functions from mempool --- src/Internal/QueryM/Ogmios/Mempool.purs | 20 ++++++++++++------- .../QueryM/Ogmios/Mempool/JsonRpc2.purs | 14 +++++++++---- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index 92f19ba3e1..e64b070305 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -30,7 +30,10 @@ import Aeson ( class DecodeAeson , class EncodeAeson , Aeson - , JsonDecodeError(UnexpectedValue, TypeMismatch) + , JsonDecodeError(TypeMismatch, UnexpectedValue) + , caseAesonNull + , caseAesonObject + , caseAesonString , decodeAeson , getField , parseJsonStringToAeson @@ -78,7 +81,6 @@ import Ctl.Internal.QueryM.Ogmios.Types , decodeResult , ogmiosDecodeErrorToError ) -import Ctl.Internal.Service.Helpers (aesonNull, aesonObject, aesonString) import Data.Argonaut.Encode.Encoders as Argonaut import Data.Bifunctor (lmap) import Data.Either (Either(Left, Right), either, isRight) @@ -95,6 +97,7 @@ import Effect.Aff (Aff, Canceler(Canceler), makeAff) import Effect.Class (liftEffect) import Effect.Exception (Error, error) import Effect.Ref as Ref +import Foreign.Object (Object) type ListenerId = String @@ -375,9 +378,6 @@ mkRequestAff listeners' webSocket logger jsonRpc2Call getLs input = do respLs.addRequest id (sBody /\ input) _wsSend webSocket (logger Debug) sBody -- Uncomment this code fragment to test `SubmitTx` request resend logic: - -- let method = aesonObject (flip getFieldOptional "methodname") body - -- when (method == Right (Just "SubmitTx")) do - -- _wsReconnect webSocket pure $ Canceler $ \err -> do liftEffect $ respLs.removeMessageListener id liftEffect $ throwError $ err @@ -497,7 +497,7 @@ instance DecodeAeson MaybeMempoolTransaction where pure $ Just $ MempoolTransaction { id: tx'.id, raw: tx'.cbor } ) <|> ( do - aesonNull tx + caseAesonNull (Left (TypeMismatch "Null")) pure $ tx pure Nothing ) pure $ MaybeMempoolTransaction $ res @@ -517,7 +517,7 @@ instance Show ReleasedMempool where instance DecodeAeson ReleasedMempool where decodeAeson = aesonObject \o -> do released <- o .: "released" - flip aesonString released $ \s -> + flip (caseAesonString (Left (TypeMismatch "String"))) released $ \s -> if s == "mempool" then pure $ ReleasedMempool else @@ -526,3 +526,9 @@ instance DecodeAeson ReleasedMempool where instance DecodeOgmios ReleasedMempool where decodeOgmios = decodeResult decodeAeson +aesonObject + :: forall (a :: Type) + . (Object Aeson -> Either JsonDecodeError a) + -> Aeson + -> Either JsonDecodeError a +aesonObject = caseAesonObject (Left (TypeMismatch "Object")) diff --git a/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs index 59209ec6f4..0806709af7 100644 --- a/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs @@ -10,9 +10,15 @@ module Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 import Prelude -import Aeson (class EncodeAeson, Aeson, JsonDecodeError, encodeAeson, getField) -import Ctl.Internal.Service.Helpers (aesonObject) -import Data.Either (Either) +import Aeson + ( class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch) + , caseAesonObject + , encodeAeson + , getField + ) +import Data.Either (Either(Left)) import Effect (Effect) import Record as Record @@ -72,5 +78,5 @@ parseJsonRpc2ResponseId :: Aeson -> Either JsonDecodeError String parseJsonRpc2ResponseId = - aesonObject $ flip getField "id" + caseAesonObject (Left (TypeMismatch "Object")) $ flip getField "id" From 2718d8a9eb0e4647b2a6786d9856735480ab488e Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Fri, 14 Feb 2025 10:14:48 -0300 Subject: [PATCH 24/27] Remove unused code --- src/Internal/QueryM/Ogmios/Mempool.purs | 33 +++++-------------- .../QueryM/Ogmios/Mempool/Dispatcher.purs | 19 ----------- test/Ogmios/GenerateFixtures.purs | 5 +-- 3 files changed, 9 insertions(+), 48 deletions(-) diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs index e64b070305..55a0a2ac5d 100644 --- a/src/Internal/QueryM/Ogmios/Mempool.purs +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -48,13 +48,10 @@ import Control.Monad.Error.Class (liftEither, throwError) import Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher ( DispatchError(JsonError) , Dispatcher - , GenericPendingRequests - , PendingRequests , RequestBody , WebsocketDispatch , mkWebsocketDispatch , newDispatcher - , newPendingRequests ) import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket ( JsWebSocket @@ -91,7 +88,6 @@ import Data.Map as Map import Data.Maybe (Maybe(Nothing, Just)) import Data.Newtype (class Newtype, wrap) import Data.Show.Generic (genericShow) -import Data.Tuple.Nested (type (/\), (/\)) import Effect (Effect) import Effect.Aff (Aff, Canceler(Canceler), makeAff) import Effect.Class (liftEffect) @@ -186,8 +182,6 @@ listeners (WebSocket _ ls) = ls -- OgmiosWebSocket Setup and PrimOps -------------------------------------------------------------------------------- -type IsTxConfirmed = TransactionHash -> Aff Boolean - mkOgmiosWebSocketAff :: Logger -> String @@ -258,21 +252,20 @@ mkOgmiosWebSocketLens -> Effect (MkServiceWebSocketLens OgmiosListeners) mkOgmiosWebSocketLens logger = do dispatcher <- newDispatcher - pendingRequests <- newPendingRequests pure $ let ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket ogmiosWebSocket ws = WebSocket ws { acquireMempool: - mkListenerSet dispatcher pendingRequests + mkListenerSet dispatcher , releaseMempool: - mkListenerSet dispatcher pendingRequests + mkListenerSet dispatcher , mempoolHasTx: - mkListenerSet dispatcher pendingRequests + mkListenerSet dispatcher , mempoolNextTx: - mkListenerSet dispatcher pendingRequests + mkListenerSet dispatcher , mempoolSizeAndCapacity: - mkListenerSet dispatcher pendingRequests + mkListenerSet dispatcher } in @@ -302,9 +295,6 @@ type ListenerSet (request :: Type) (response :: Type) = -> Effect Unit , removeMessageListener :: ListenerId -> Effect Unit -- ^ Removes ID from dispatch map and pending requests queue. - , addRequest :: ListenerId -> RequestBody /\ request -> Effect Unit - -- ^ Saves request body until the request is fulfilled. The body is used - -- to replay requests in case of a WebSocket failure. } mkAddMessageListener @@ -324,12 +314,10 @@ mkAddMessageListener dispatcher = mkRemoveMessageListener :: forall (requestData :: Type) . Dispatcher - -> GenericPendingRequests requestData -> (ListenerId -> Effect Unit) -mkRemoveMessageListener dispatcher pendingRequests = +mkRemoveMessageListener dispatcher = \reflection -> do Ref.modify_ (Map.delete reflection) dispatcher - Ref.modify_ (Map.delete reflection) pendingRequests -- we manipluate closures to make the DispatchIdMap updateable using these -- methods, this can be picked up by a query or cancellation function @@ -337,16 +325,12 @@ mkListenerSet :: forall (request :: Type) (response :: Type) . DecodeOgmios response => Dispatcher - -> PendingRequests -> ListenerSet request response -mkListenerSet dispatcher pendingRequests = +mkListenerSet dispatcher = { addMessageListener: mkAddMessageListener dispatcher , removeMessageListener: - mkRemoveMessageListener dispatcher pendingRequests - , addRequest: - \reflection (requestBody /\ _) -> - Ref.modify_ (Map.insert reflection requestBody) pendingRequests + mkRemoveMessageListener dispatcher } mkRequestAff @@ -375,7 +359,6 @@ mkRequestAff listeners' webSocket logger jsonRpc2Call getLs input = do respLs.removeMessageListener id cont $ lmap ogmiosDecodeErrorToError res ) - respLs.addRequest id (sBody /\ input) _wsSend webSocket (logger Debug) sBody -- Uncomment this code fragment to test `SubmitTx` request resend logic: pure $ Canceler $ \err -> do diff --git a/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs b/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs index 6a96808e7c..f1fb561a6a 100644 --- a/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs @@ -1,28 +1,22 @@ module Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher ( DispatchError(JsonError, FaultError, ListenerCancelled) , Dispatcher - , GenericPendingRequests - , PendingRequests - , PendingSubmitTxRequests , RequestBody , WebsocketDispatch , dispatchErrorToError , mkWebsocketDispatch , newDispatcher - , newPendingRequests , ListenerId ) where import Prelude import Aeson (Aeson, JsonDecodeError, stringifyAeson) -import Cardano.Types.TransactionHash (TransactionHash) import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 (parseJsonRpc2ResponseId) import Data.Either (Either(Left, Right)) import Data.Map (Map) import Data.Map (empty, lookup) as Map import Data.Maybe (Maybe(Just, Nothing)) -import Data.Tuple.Nested (type (/\)) import Effect (Effect) import Effect.Exception (Error, error) import Effect.Ref (Ref) @@ -76,16 +70,3 @@ mkWebsocketDispatch dispatcher aeson = do Nothing -> pure $ Left $ ListenerCancelled reflection Just action -> pure $ Right $ action aeson -type ShouldResend = Boolean - -type GenericPendingRequests (requestData :: Type) = - Ref (Map ListenerId requestData) - -newPendingRequests - :: forall (requestData :: Type). Effect (GenericPendingRequests requestData) -newPendingRequests = Ref.new Map.empty - -type PendingRequests = GenericPendingRequests RequestBody - -type PendingSubmitTxRequests = GenericPendingRequests - (RequestBody /\ TransactionHash) diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index ca03a96b8b..a08d98db22 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -11,7 +11,6 @@ import Ctl.Internal.QueryM.Ogmios.Mempool ( ListenerSet , WebSocket(WebSocket) , defaultMessageListener - , mkListenerSet , mkOgmiosCallType , mkRequestAff ) @@ -30,7 +29,7 @@ import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 (JsonRpc2Call) import Ctl.Internal.QueryM.Ogmios.Types (class DecodeOgmios) import Ctl.Internal.ServerConfig (ServerConfig, defaultOgmiosWsConfig, mkWsUrl) -import Data.Either (Either(Left, Right)) +import Data.Either (Either(Left)) import Data.Log.Level (LogLevel(Trace, Debug)) import Data.Map as Map import Data.Newtype (class Newtype, unwrap, wrap) @@ -74,8 +73,6 @@ mkWebSocket lvl serverCfg cb = do _onWsMessage ws (logger Debug) $ defaultMessageListener (\_ _ -> pure unit) [ messageDispatch ] void $ _onWsError ws $ const onError - cb $ Right $ WebSocket ws - (mkListenerSet dispatcher pendingRequests) pure $ \err -> cb $ Left $ err where logger :: LogLevel -> String -> Effect Unit From 303e7f46dff36dc66564dacd50a80953283a37bb Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Tue, 18 Feb 2025 17:08:31 -0300 Subject: [PATCH 25/27] Refactor `OgmiosDecodeError` --- src/Internal/QueryM/Ogmios.purs | 21 ++++++++++----------- src/Internal/QueryM/Ogmios/Types.purs | 22 ++++++++-------------- test/Ogmios/EvaluateTx.purs | 14 ++++---------- 3 files changed, 22 insertions(+), 35 deletions(-) diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 5b94985458..5b75240196 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -15,14 +15,11 @@ import Prelude import Aeson (class EncodeAeson, Aeson, parseJsonStringToAeson, stringifyAeson) import Aeson as Aeson import Affjax (Error, Response, defaultRequest) as Affjax +import Affjax (printError) import Affjax.RequestBody as Affjax.RequestBody import Affjax.RequestHeader as Affjax.RequestHeader import Affjax.ResponseFormat (string) as Affjax.ResponseFormat import Affjax.StatusCode (StatusCode(StatusCode)) -import Cardano.Provider.Error - ( ClientError(ClientHttpError, ClientHttpResponseError, ClientDecodeJsonError) - , ServiceError(ServiceOtherError) - ) import Cardano.Provider.TxEvaluation as Provider import Cardano.Types.CborBytes (CborBytes) import Cardano.Types.Chain as Chain @@ -39,8 +36,9 @@ import Ctl.Internal.QueryM.Ogmios.Types , ChainTipQR(CtChainPoint, CtChainOrigin) , CurrentEpoch , DelegationsAndRewardsR - , OgmiosDecodeError(ClientErrorResponse) + , OgmiosDecodeError(ErrorResponse, InvalidRpcResponse) , OgmiosEraSummaries + , OgmiosError(OgmiosError) , OgmiosProtocolParameters , OgmiosSystemStart , OgmiosTxEvaluationR @@ -55,7 +53,7 @@ import Data.ByteArray (byteArrayToHex) import Data.Either (Either(Left), either) import Data.HTTP.Method (Method(POST)) import Data.Lens (_Right, to, (^?)) -import Data.Maybe (Maybe(Just)) +import Data.Maybe (Maybe(Just, Nothing)) import Data.Newtype (unwrap, wrap) import Data.Time.Duration (Milliseconds(Milliseconds)) import Data.Tuple.Nested (type (/\), (/\)) @@ -202,12 +200,13 @@ handleAffjaxOgmiosResponse -> Either OgmiosDecodeError result handleAffjaxOgmiosResponse = handleAffjaxResponseGeneric - (ClientErrorResponse <<< ClientHttpError) - ( \statusCode body -> ClientErrorResponse $ ClientHttpResponseError - (wrap statusCode) - (ServiceOtherError body) + ( \err -> ErrorResponse $ Just $ OgmiosError + { code: 0, message: printError err, data: Nothing } + ) + ( \code body -> ErrorResponse $ Just $ OgmiosError + { code, message: "body: " <> body, data: Nothing } ) - (\body -> ClientErrorResponse <<< ClientDecodeJsonError body) + (\_body jsonErr -> InvalidRpcResponse jsonErr) parseJsonStringToAeson decodeOgmios diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs index c470597c48..9aa1cc7fba 100644 --- a/src/Internal/QueryM/Ogmios/Types.purs +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -22,7 +22,7 @@ module Ctl.Internal.QueryM.Ogmios.Types , decodeOgmios , class DecodeOgmios , OgmiosDecodeError - ( ClientErrorResponse + ( InvalidRpcError , InvalidRpcResponse , ErrorResponse ) @@ -58,10 +58,6 @@ import Aeson , (.:?) ) import Cardano.AsCbor (decodeCbor, encodeCbor) -import Cardano.Provider.Error - ( ClientError(ClientDecodeJsonError) - , pprintClientError - ) import Cardano.Provider.TxEvaluation ( ExecutionUnits , OgmiosTxOut @@ -1009,9 +1005,9 @@ instance DecodeAeson OgmiosError where data OgmiosDecodeError -- Server responded with error. = ErrorResponse (Maybe OgmiosError) - -- Server responded with result, parsing of which failed - | ClientErrorResponse ClientError - -- Received JsonRpc2Response was not of the right format. + -- Received JsonRpc2 error was not of the right format. + | InvalidRpcError JsonDecodeError + -- Received JsonRpc2 response was not of the right format. | InvalidRpcResponse JsonDecodeError derive instance Generic OgmiosDecodeError _ @@ -1022,8 +1018,8 @@ instance Show OgmiosDecodeError where pprintOgmiosDecodeError :: OgmiosDecodeError -> String pprintOgmiosDecodeError (ErrorResponse err) = "Ogmios responded with error: " <> maybe "" pprintOgmiosError err -pprintOgmiosDecodeError (ClientErrorResponse err) = - "Ogmios responded with error: " <> pprintClientError err +pprintOgmiosDecodeError (InvalidRpcError err) = + "Ogmios error was not of the right format: " <> printJsonDecodeError err pprintOgmiosDecodeError (InvalidRpcResponse err) = "Ogmios response was not of the right format: " <> printJsonDecodeError err @@ -1053,15 +1049,13 @@ makeDecodeOgmios decoders aeson = do -- Expected result, got it Just (Right x) /\ _ -> pure x -- Expected result, got it in a wrong format - Just (Left err) /\ _ -> Left $ ClientErrorResponse $ ClientDecodeJsonError - (stringifyAeson aeson) - err + Just (Left err) /\ _ -> Left $ InvalidRpcResponse err -- Got an expected error _ /\ Just (Right x) -> pure x -- Got an unexpected error _ -> do err :: Maybe OgmiosError <- sequence $ - lmap InvalidRpcResponse <<< decodeAeson <$> json.error + lmap InvalidRpcError <<< decodeAeson <$> json.error Left $ ErrorResponse err -- | Decode "result" field of ogmios response. diff --git a/test/Ogmios/EvaluateTx.purs b/test/Ogmios/EvaluateTx.purs index 6496a0b93c..1ca1ca8499 100644 --- a/test/Ogmios/EvaluateTx.purs +++ b/test/Ogmios/EvaluateTx.purs @@ -2,8 +2,6 @@ module Test.Ctl.Ogmios.EvaluateTx (suite) where import Prelude -import Aeson (stringifyAeson) -import Cardano.Provider.Error (ClientError(ClientDecodeJsonError)) import Cardano.Provider.TxEvaluation ( ExecutionUnits , RedeemerPointer @@ -15,10 +13,11 @@ import Cardano.Types (BigNum) import Cardano.Types.BigNum as BigNum import Cardano.Types.RedeemerTag (RedeemerTag(Spend, Cert, Reward)) import Ctl.Internal.QueryM.Ogmios.Types - ( OgmiosDecodeError(ClientErrorResponse) + ( OgmiosDecodeError(InvalidRpcResponse) , OgmiosTxEvaluationR , decodeOgmios ) +import Data.Argonaut.Decode.Error (JsonDecodeError(TypeMismatch)) import Data.Either (Either(Left, Right)) import Data.Map as Map import Data.Maybe (fromJust) @@ -59,13 +58,8 @@ suite = do (map (\(r :: OgmiosTxEvaluationR) -> unwrap r) <<< decodeOgmios) body txEvalR `shouldSatisfy` case _ of - Left - ( ClientErrorResponse - ( ClientDecodeJsonError - bodyStr - _ - ) - ) -> bodyStr == stringifyAeson body + Left (InvalidRpcResponse (TypeMismatch errMsg)) -> errMsg == + "Expected redeemer to be one of: (spend|mint|publish|withdraw|vote|propose)" _ -> false test "Successfully decodes a failed execution response (Incompatible era)" From ace529ef5333b7f94cba0adf59466ed46ff9e705 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Tue, 18 Feb 2025 17:23:23 -0300 Subject: [PATCH 26/27] Improve HTTP handler readability --- src/Internal/QueryM.purs | 13 ++++----- src/Internal/QueryM/HttpUtils.purs | 42 ++++++++++++++---------------- src/Internal/QueryM/Ogmios.purs | 21 ++++++++------- 3 files changed, 39 insertions(+), 37 deletions(-) diff --git a/src/Internal/QueryM.purs b/src/Internal/QueryM.purs index 4ee3ea0ff8..57999104d6 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -132,10 +132,11 @@ handleAffjaxResponse -> Either ClientError result handleAffjaxResponse = handleAffjaxResponseGeneric - ClientHttpError - ( \statusCode body -> ClientHttpResponseError (wrap statusCode) + { httpError: ClientHttpError + , httpStatusCodeError: \statusCode body -> ClientHttpResponseError + (wrap statusCode) (ServiceOtherError body) - ) - ClientDecodeJsonError - (decodeAeson <=< parseJsonStringToAeson) - pure + , decodeError: ClientDecodeJsonError + , parse: (decodeAeson <=< parseJsonStringToAeson) + , transform: pure + } diff --git a/src/Internal/QueryM/HttpUtils.purs b/src/Internal/QueryM/HttpUtils.purs index 02f2fa6d16..c12eee30ce 100644 --- a/src/Internal/QueryM/HttpUtils.purs +++ b/src/Internal/QueryM/HttpUtils.purs @@ -15,6 +15,19 @@ import Data.Either (Either(Left, Right)) -- Affjax -------------------------------------------------------------------------------- +type AffjaxResponseHandler err intermediate result = + { httpError :: Affjax.Error -> err + -- ^ Convert an Affjax error into custom error + , httpStatusCodeError :: Int -> String -> err + -- ^ Convert a non-2xx status code into custom error + , decodeError :: String -> JsonDecodeError -> err + -- ^ Wrap aeson-parse/decode errors + , parse :: String -> Either JsonDecodeError intermediate + -- ^ Parse the response body + , transform :: intermediate -> Either err result + -- ^ Function from `intermediate` to `result` + } + -- Checks response status code and returns `ClientError` in case of failure, -- otherwise attempts to decode the result. -- @@ -23,32 +36,17 @@ import Data.Either (Either(Left, Right)) handleAffjaxResponseGeneric :: forall err intermediate result - . (Affjax.Error -> err) - -- ^ Convert an Affjax error into custom error - -> (Int -> String -> err) - -- ^ Convert a non-2xx status code into custom error - -> (String -> JsonDecodeError -> err) - -- ^ Wrap aeson-parse/decode errors - -> (String -> Either JsonDecodeError intermediate) - -- ^ Parse the response body - -> (intermediate -> Either err result) - -- ^ Function from `intermediate` to `result` + . AffjaxResponseHandler err intermediate result -> Either Affjax.Error (Affjax.Response String) - -- ^ Argument -> Either err result -handleAffjaxResponseGeneric - mkHttpError - mkHttpResponseError - mkDecodeError - decodeAeson - mkResult = +handleAffjaxResponseGeneric handler = case _ of Left affjaxError -> - Left (mkHttpError affjaxError) + Left (handler.httpError affjaxError) Right { status: Affjax.StatusCode.StatusCode statusCode, body } | statusCode < 200 || statusCode > 299 -> - Left (mkHttpResponseError statusCode body) + Left (handler.httpStatusCodeError statusCode body) | otherwise -> do - intermediate <- lmap (mkDecodeError body) do - decodeAeson body - mkResult intermediate + intermediate <- lmap (handler.decodeError body) do + handler.parse body + handler.transform intermediate diff --git a/src/Internal/QueryM/Ogmios.purs b/src/Internal/QueryM/Ogmios.purs index 5b75240196..06c9098e0f 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -200,15 +200,18 @@ handleAffjaxOgmiosResponse -> Either OgmiosDecodeError result handleAffjaxOgmiosResponse = handleAffjaxResponseGeneric - ( \err -> ErrorResponse $ Just $ OgmiosError - { code: 0, message: printError err, data: Nothing } - ) - ( \code body -> ErrorResponse $ Just $ OgmiosError - { code, message: "body: " <> body, data: Nothing } - ) - (\_body jsonErr -> InvalidRpcResponse jsonErr) - parseJsonStringToAeson - decodeOgmios + { httpError: + ( \err -> ErrorResponse $ Just $ OgmiosError + { code: 0, message: printError err, data: Nothing } + ) + , httpStatusCodeError: + ( \code body -> ErrorResponse $ Just $ OgmiosError + { code, message: "body: " <> body, data: Nothing } + ) + , decodeError: (\_body jsonErr -> InvalidRpcResponse jsonErr) + , parse: parseJsonStringToAeson + , transform: decodeOgmios + } ogmiosErrorHandler :: forall a m From d8ba070ed366086cfce1ec5affa976acb1533cb6 Mon Sep 17 00:00:00 2001 From: Marcus Fernandes Date: Tue, 18 Feb 2025 17:38:54 -0300 Subject: [PATCH 27/27] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ee5a272769..0c7d9948c5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -104,6 +104,7 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/) - Switched to the aggregate `@mlabs-haskell/ctl-npm-meta` package for NPM dependencies (see the [section on updating JS dependencies in the docs](./doc/ctl-as-dependency.md)) ([#1666](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1666)) - Ignore **any** tx evaluation errors if tx marked invalid. Previously, certain internal evaluation errors were not properly handled, leading to unexpected behavior for a subset of explicitly marked "invalid" transactions. ([#1668](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1668)) - `Provider` (previously called `QueryHandle`) is extracted to its own package [purescript-cardano-provider](https://github.com/mlabs-haskell/purescript-cardano-provider) using module names in the format `Cardano.Provider.*` ([#1671](https://github.com/Plutonomicon/cardano-transaction-lib/pull/1671)) +- Switched from WebSocket to HTTP when interfacing with Ogmios. Note: Mempool functionality still uses WebSocket, as it requires a persistent connection to track state. ([#1575](https://github.com/Plutonomicon/cardano-transaction-lib/issues/1575)) ### Fixed