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 diff --git a/src/Contract/Backend/Ogmios.purs b/src/Contract/Backend/Ogmios.purs index c5b5af454e..453a47bfa0 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.Ogmios (submitTxOgmios) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types (SubmitTxR) 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 $ Ogmios.submitTxOgmios txhash cbor diff --git a/src/Contract/Backend/Ogmios/Mempool.purs b/src/Contract/Backend/Ogmios/Mempool.purs index 95a0792033..b2ae592998 100644 --- a/src/Contract/Backend/Ogmios/Mempool.purs +++ b/src/Contract/Backend/Ogmios/Mempool.purs @@ -2,14 +2,16 @@ -- | 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 - , fetchMempoolTxs + ( acquireMempoolSnapshot , mempoolSnapshotHasTx , mempoolSnapshotNextTx + , fetchMempoolTxs , mempoolSnapshotSizeAndCapacity , releaseMempool , withMempoolSnapshot + , MempoolEnv + , MempoolMT(MempoolMT) + , MempoolM ) where import Contract.Prelude @@ -17,71 +19,85 @@ 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 Ctl.Internal.Contract.Monad (wrapQueryM) -import Ctl.Internal.QueryM - ( acquireMempoolSnapshot - , mempoolSnapshotHasTx - , mempoolSnapshotNextTx - , mempoolSnapshotSizeAndCapacity - , releaseMempool - ) as QueryM -import Ctl.Internal.QueryM.Ogmios - ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) +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.Ogmios.Mempool + ( ListenerSet + , OgmiosListeners + , OgmiosWebSocket + , acquireMempoolSnapshotCall + , listeners + , mempoolSnapshotHasTxCall + , mempoolSnapshotNextTxCall + , mempoolSnapshotSizeAndCapacityCall + , mkRequestAff + , releaseMempoolCall + , underlyingWebSocket + ) +import Ctl.Internal.QueryM.Ogmios.Mempool + ( MempoolSizeAndCapacity , 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)) -import Data.Maybe (Maybe(Just, Nothing)) -import Effect.Exception (error) +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) --- | 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 +---------------- +-- Mempool monad +---------------- --- | 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 +type MempoolEnv = + { ogmiosWs :: OgmiosWebSocket + , logLevel :: LogLevel + , customLogger :: Maybe (LogLevel -> Message -> Aff Unit) + , suppressLogs :: Boolean + } --- | 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 $ QueryM.mempoolSnapshotNextTx 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 +type MempoolM = MempoolMT Aff --- | The acquired snapshot’s size (in bytes), number of transactions, and --- | capacity (in bytes). -mempoolSnapshotSizeAndCapacity - :: Ogmios.MempoolSnapshotAcquired -> Contract Ogmios.MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacity = wrapQueryM <<< - QueryM.mempoolSnapshotSizeAndCapacity +newtype MempoolMT (m :: Type -> Type) (a :: Type) = + MempoolMT (ReaderT MempoolEnv m a) --- | Release the connection to the Local TX Monitor. -releaseMempool - :: Ogmios.MempoolSnapshotAcquired -> Contract Unit -releaseMempool = wrapQueryM <<< QueryM.releaseMempool +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 @@ -92,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 @@ -100,3 +116,85 @@ fetchMempoolTxs ms = Array.fromFoldable <$> go case nextTX of Just tx -> Cons tx <$> go Nothing -> pure mempty + +acquireMempoolSnapshot + :: MempoolM Ogmios.MempoolSnapshotAcquired +acquireMempoolSnapshot = + mkOgmiosRequest + acquireMempoolSnapshotCall + _.acquireMempool + unit + +mempoolSnapshotHasTx + :: Ogmios.MempoolSnapshotAcquired + -> TransactionHash + -> MempoolM Boolean +mempoolSnapshotHasTx ms txh = + unwrap <$> mkOgmiosRequest + (mempoolSnapshotHasTxCall ms) + _.mempoolHasTx + txh + +mempoolSnapshotSizeAndCapacity + :: Ogmios.MempoolSnapshotAcquired + -> MempoolM Ogmios.MempoolSizeAndCapacity +mempoolSnapshotSizeAndCapacity ms = + mkOgmiosRequest + (mempoolSnapshotSizeAndCapacityCall ms) + _.mempoolSizeAndCapacity + unit + +releaseMempool + :: Ogmios.MempoolSnapshotAcquired + -> MempoolM Unit +releaseMempool ms = + unit <$ mkOgmiosRequest + (releaseMempoolCall ms) + _.releaseMempool + unit + +mempoolSnapshotNextTx + :: Ogmios.MempoolSnapshotAcquired + -> 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 `MempoolM` +mkOgmiosRequest + :: forall (request :: Type) (response :: Type) + . JsonRpc2.JsonRpc2Call request response + -> (OgmiosListeners -> ListenerSet request response) + -> request + -> MempoolM response +mkOgmiosRequest jsonRpc2Call getLs inp = do + listeners' <- asks $ listeners <<< _.ogmiosWs + websocket <- asks $ underlyingWebSocket <<< _.ogmiosWs + 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 + -> MempoolM response +mkRequest listeners' ws jsonRpc2Call getLs inp = do + logger <- getLogger + liftAff $ mkRequestAff listeners' ws logger jsonRpc2Call getLs inp + where + getLogger :: MempoolM Logger + getLogger = do + logLevel <- asks $ _.logLevel + mbCustomLogger <- asks $ _.customLogger + pure $ mkLogger logLevel mbCustomLogger + 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 a337facb94..e95b8e806b 100644 --- a/src/Internal/Contract/Monad.purs +++ b/src/Internal/Contract/Monad.purs @@ -54,18 +54,13 @@ 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 - , mkOgmiosWebSocketAff - , underlyingWebSocket +import Ctl.Internal.QueryM (QueryEnv, QueryM) +import Ctl.Internal.QueryM.Ogmios (getProtocolParameters, getSystemStartTime) +import Ctl.Internal.QueryM.Ogmios.Types + ( OgmiosDecodeError + , pprintOgmiosDecodeError ) -import Ctl.Internal.QueryM.Kupo (isTxConfirmedAff) import Ctl.Internal.Service.Blockfrost ( BlockfrostServiceM , runBlockfrostServiceM @@ -77,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) @@ -85,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) @@ -262,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 -> @@ -270,13 +264,8 @@ buildBackend logger = case _ of where buildCtlBackend :: CtlBackendParams -> Aff CtlBackend buildCtlBackend { ogmiosConfig, kupoConfig } = do - let isTxConfirmed = map isRight <<< isTxConfirmedAff kupoConfig - ogmiosWs <- mkOgmiosWebSocketAff isTxConfirmed logger ogmiosConfig pure - { ogmios: - { config: ogmiosConfig - , ws: ogmiosWs - } + { ogmiosConfig , kupoConfig } @@ -290,10 +279,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: _ } @@ -306,9 +317,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 @@ -342,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. @@ -458,14 +458,12 @@ mkQueryEnv :: forall (rest :: Row Type). LogParams rest -> CtlBackend -> QueryEnv mkQueryEnv params ctlBackend = { config: - { kupoConfig: ctlBackend.kupoConfig + { ogmiosConfig: ctlBackend.ogmiosConfig + , kupoConfig: ctlBackend.kupoConfig , logLevel: params.logLevel , customLogger: params.customLogger , suppressLogs: params.suppressLogs } - , runtime: - { ogmiosWs: ctlBackend.ogmios.ws - } } -------------------------------------------------------------------------------- @@ -480,3 +478,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..2be4fb6a2a 100644 --- a/src/Internal/Contract/Provider.purs +++ b/src/Internal/Contract/Provider.purs @@ -16,9 +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 (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.CurrentEpoch (getCurrentEpoch) as Ogmios +import Ctl.Internal.QueryM.EraSummaries (getEraSummaries) as Ogmios import Ctl.Internal.QueryM.Kupo ( getDatumByHash , getOutputAddressesByTxHash @@ -28,12 +27,17 @@ import Ctl.Internal.QueryM.Kupo , isTxConfirmed , utxosAt ) as Kupo -import Ctl.Internal.QueryM.Ogmios (SubmitTxR(SubmitFail, SubmitTxSuccess)) +import Ctl.Internal.QueryM.Ogmios + ( evaluateTxOgmios + , getChainTip + , submitTxOgmios + ) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types (SubmitTxR(SubmitFail, SubmitTxSuccess)) import Ctl.Internal.QueryM.Pools ( getPoolIds , getPubKeyHashDelegationsAndRewards , getValidatorHashDelegationsAndRewards - ) as QueryM + ) as Ogmios 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' 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 <- QueryM.submitTxOgmios txHash txCborBytes + result <- Ogmios.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 -> + runQueryM' do + let txBytes = encodeCbor tx + Ogmios.evaluateTxOgmios txBytes (wrap additionalUtxos) + , getEraSummaries: Right <$> runQueryM' Ogmios.getEraSummaries + , getPoolIds: Right <$> runQueryM' Ogmios.getPoolIds , getPubKeyHashDelegationsAndRewards: \_ pubKeyHash -> Right <$> runQueryM' - (QueryM.getPubKeyHashDelegationsAndRewards pubKeyHash) + (Ogmios.getPubKeyHashDelegationsAndRewards pubKeyHash) , getValidatorHashDelegationsAndRewards: \_ validatorHash -> Right <$> runQueryM' - (QueryM.getValidatorHashDelegationsAndRewards $ wrap validatorHash) + (Ogmios.getValidatorHashDelegationsAndRewards $ wrap validatorHash) } where diff --git a/src/Internal/Contract/ProviderBackend.purs b/src/Internal/Contract/ProviderBackend.purs index 08b1e546a6..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 (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 03b7752b9a..57999104d6 100644 --- a/src/Internal/QueryM.purs +++ b/src/Internal/QueryM.purs @@ -1,189 +1,45 @@ -- | 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 - ( module ExportDispatcher - , module ExportServerConfig - , ClusterSetup - , ListenerSet - , OgmiosListeners - , OgmiosWebSocket + ( QueryM + , QueryEnv , QueryConfig - , QueryM + , ClusterSetup , 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 Affjax.StatusCode as Affjax.StatusCode +import Aeson (class DecodeAeson, decodeAeson, parseJsonStringToAeson) +import Affjax (Error, Response) as Affjax 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.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 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 Ctl.Internal.QueryM.HttpUtils (handleAffjaxResponseGeneric) +import Ctl.Internal.ServerConfig (ServerConfig) +import Data.Either (Either) +import Data.Log.Level (LogLevel) 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.Maybe (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 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 +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 @@ -205,25 +61,16 @@ type ClusterSetup = -- | - logging level -- | - optional custom logger type QueryConfig = - { kupoConfig :: ServerConfig + { 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 } type QueryM = QueryMT Aff @@ -278,657 +125,18 @@ 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 - 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 --------------------------------------------------------------------------------- - -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 --------------------------------------------------------------------------------- - --- 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) - --- 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 +handleAffjaxResponse = + handleAffjaxResponseGeneric + { httpError: ClientHttpError + , httpStatusCodeError: \statusCode body -> ClientHttpResponseError + (wrap statusCode) + (ServiceOtherError body) + , decodeError: ClientDecodeJsonError + , parse: (decodeAeson <=< parseJsonStringToAeson) + , transform: pure + } diff --git a/src/Internal/QueryM/CurrentEpoch.purs b/src/Internal/QueryM/CurrentEpoch.purs index f023fb16fa..48e3ff7679 100644 --- a/src/Internal/QueryM/CurrentEpoch.purs +++ b/src/Internal/QueryM/CurrentEpoch.purs @@ -5,11 +5,17 @@ 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.Ogmios (currentEpoch) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types (CurrentEpoch, pprintOgmiosDecodeError) +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 Ogmios.CurrentEpoch -getCurrentEpoch = - mkOgmiosRequest Ogmios.queryCurrentEpochCall _.currentEpoch unit +getCurrentEpoch :: QueryM CurrentEpoch +getCurrentEpoch = Ogmios.currentEpoch + >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + pure diff --git a/src/Internal/QueryM/EraSummaries.purs b/src/Internal/QueryM/EraSummaries.purs index 21e5dc88c6..c3e6b5e9d3 100644 --- a/src/Internal/QueryM/EraSummaries.purs +++ b/src/Internal/QueryM/EraSummaries.purs @@ -6,12 +6,17 @@ 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.Ogmios (eraSummaries) as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types (pprintOgmiosDecodeError) +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 = - unwrap <$> mkOgmiosRequest Ogmios.queryEraSummariesCall _.eraSummaries unit +getEraSummaries = Ogmios.eraSummaries + >>= either (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< unwrap) diff --git a/src/Internal/QueryM/HttpUtils.purs b/src/Internal/QueryM/HttpUtils.purs new file mode 100644 index 0000000000..c12eee30ce --- /dev/null +++ b/src/Internal/QueryM/HttpUtils.purs @@ -0,0 +1,52 @@ +-- | 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 +-------------------------------------------------------------------------------- + +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. +-- +-- This function solves the problem described there: +-- https://github.com/eviefp/purescript-affjax-errors + +handleAffjaxResponseGeneric + :: forall err intermediate result + . AffjaxResponseHandler err intermediate result + -> Either Affjax.Error (Affjax.Response String) + -> Either err result +handleAffjaxResponseGeneric handler = + case _ of + Left affjaxError -> + Left (handler.httpError affjaxError) + Right { status: Affjax.StatusCode.StatusCode statusCode, body } + | statusCode < 200 || statusCode > 299 -> + Left (handler.httpStatusCodeError statusCode body) + | otherwise -> do + intermediate <- lmap (handler.decodeError body) do + handler.parse body + handler.transform intermediate diff --git a/src/Internal/QueryM/JsonRpc2.purs b/src/Internal/QueryM/JsonRpc2.purs deleted file mode 100644 index de5454d8db..0000000000 --- a/src/Internal/QueryM/JsonRpc2.purs +++ /dev/null @@ -1,232 +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, 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 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 - | 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 (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 de3da772d9..06c9098e0f 100644 --- a/src/Internal/QueryM/Ogmios.purs +++ b/src/Internal/QueryM/Ogmios.purs @@ -1,1252 +1,235 @@ --- | 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) - , acquireMempoolSnapshotCall - , aesonArray - , aesonObject - , evaluateTxCall - , queryStakePoolsCall - , mempoolSnapshotHasTxCall - , mempoolSnapshotNextTxCall - , mempoolSnapshotSizeAndCapacityCall - , mkOgmiosCallType - , mkOgmiosCallTypeNoArgs - , queryChainTipCall - , queryCurrentEpochCall - , queryEraSummariesCall - , queryProtocolParametersCall - , querySystemStartCall - , queryDelegationsAndRewards - , releaseMempoolCall - , submitTxCall - , submitSuccessPartialResp - , parseIpv6String - , rationalToSubcoin + ( getSystemStartTime + , getChainTip + , currentEpoch + , submitTxOgmios + , poolParameters + , delegationsAndRewards + , eraSummaries + , getProtocolParameters + , evaluateTxOgmios ) where import Prelude -import Aeson - ( class DecodeAeson - , class EncodeAeson - , Aeson - , JsonDecodeError(AtKey, TypeMismatch, UnexpectedValue, MissingValue) - , caseAesonArray - , caseAesonNull - , caseAesonObject - , caseAesonString - , decodeAeson - , encodeAeson - , fromArray - , fromString - , getField - , isNull - , 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 Cardano.Serialization.Lib (fromBytes, ipv4_new) -import Cardano.Types - ( 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 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.TxEvaluation as Provider import Cardano.Types.CborBytes (CborBytes) -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) - , 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.Ipv4 (Ipv4(Ipv4)) -import Cardano.Types.Ipv6 (Ipv6) -import Cardano.Types.NativeScript - ( NativeScript - ( ScriptPubkey - , ScriptAll - , ScriptAny - , ScriptNOfK - , TimelockStart - , TimelockExpiry - ) - ) -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.ScriptRef (ScriptRef(NativeScriptRef, PlutusScriptRef)) -import Cardano.Types.Slot (Slot(Slot)) +import Cardano.Types.Chain as Chain 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 Ctl.Internal.Helpers (encodeMap, showWithParens) -import Ctl.Internal.QueryM.JsonRpc2 +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.QueryM (QueryM) +import Ctl.Internal.QueryM.HttpUtils (handleAffjaxResponseGeneric) +import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios - , JsonRpc2Call - , JsonRpc2Request - , OgmiosError - , decodeErrorOrResult - , decodeResult - , mkCallType - ) -import Ctl.Internal.Types.ProtocolParameters - ( ProtocolParameters(ProtocolParameters) + , AdditionalUtxoSet + , ChainTipQR(CtChainPoint, CtChainOrigin) + , CurrentEpoch + , DelegationsAndRewardsR + , OgmiosDecodeError(ErrorResponse, InvalidRpcResponse) + , OgmiosEraSummaries + , OgmiosError(OgmiosError) + , OgmiosProtocolParameters + , OgmiosSystemStart + , OgmiosTxEvaluationR + , PoolParametersR + , StakePoolsQueryArgument + , SubmitTxR + , decodeOgmios + , pprintOgmiosDecodeError ) -import Ctl.Internal.Types.Rational (Rational, (%)) -import Ctl.Internal.Types.Rational as Rational -import Ctl.Internal.Types.SystemStart - ( 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) -import Data.ByteArray (byteArrayFromIntArray, byteArrayToHex, hexToByteArray) -import Data.Either (Either(Left, Right), either, note) -import Data.Foldable (fold, foldl) -import Data.Generic.Rep (class Generic) -import Data.Int (fromString) as Int -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), 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.Tuple (Tuple(Tuple)) +import Ctl.Internal.ServerConfig (ServerConfig, mkHttpUrl) +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, Nothing)) +import Data.Newtype (unwrap, wrap) +import Data.Time.Duration (Milliseconds(Milliseconds)) import Data.Tuple.Nested (type (/\), (/\)) -import Data.UInt (UInt) -import Foreign.Object (Object) -import Foreign.Object as Object -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/ --------------------------------------------------------------------------------- +import Effect.Aff (Aff, delay) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Exception (Error, error) --- | Queries Ogmios for the system start Datetime -querySystemStartCall :: JsonRpc2Call Unit OgmiosSystemStart -querySystemStartCall = mkOgmiosCallTypeNoArgs "queryNetwork/startTime" +eraSummaries :: QueryM (Either OgmiosDecodeError OgmiosEraSummaries) +eraSummaries = ogmiosQueryNoParams "queryLedgerState/eraSummaries" --- | Queries Ogmios for the current epoch -queryCurrentEpochCall :: JsonRpc2Call Unit CurrentEpoch -queryCurrentEpochCall = mkOgmiosCallTypeNoArgs "queryLedgerState/epoch" +getSystemStartTime :: QueryM (Either OgmiosDecodeError OgmiosSystemStart) +getSystemStartTime = ogmiosQueryNoParams "queryNetwork/startTime" --- | 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 +getProtocolParameters + :: QueryM (Either OgmiosDecodeError OgmiosProtocolParameters) +getProtocolParameters = ogmiosQueryNoParams "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 - :: JsonRpc2Call (CborBytes /\ AdditionalUtxoSet) OgmiosTxEvaluationR -evaluateTxCall = mkOgmiosCallType - { method: "evaluateTransaction" - , params: \(cbor /\ utxoqr) -> - { transaction: { cbor: byteArrayToHex $ unwrap cbor } - , additionalUtxo: utxoqr - } - } - --------------------------------------------------------------------------------- --- 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: _ } - } +getChainTip :: QueryM Chain.Tip +getChainTip = do + ogmiosChainTipToTip <$> ogmiosErrorHandler + (ogmiosQueryNoParams "queryNetwork/tip") + where + ogmiosChainTipToTip :: ChainTipQR -> Chain.Tip + ogmiosChainTipToTip = case _ of + CtChainOrigin _ -> Chain.TipAtGenesis + CtChainPoint { slot, id } -> Chain.Tip $ wrap + { slot, blockHeaderHash: wrap $ unwrap id } + +currentEpoch :: QueryM (Either OgmiosDecodeError CurrentEpoch) +currentEpoch = ogmiosQueryNoParams "queryLedgerState/epoch" + +submitTxOgmios :: TransactionHash -> CborBytes -> QueryM SubmitTxR +submitTxOgmios txHash tx = ogmiosErrorHandlerWithArg submitTx + (txHash /\ tx) + where + submitTx (_ /\ cbor) = ogmiosQueryParams "submitTransaction" + { transaction: + { cbor: byteArrayToHex (unwrap cbor) + } + } -mempoolSnapshotNextTxCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit MaybeMempoolTransaction -mempoolSnapshotNextTxCall _ = mkOgmiosCallType - { method: "nextTransaction" - , params: const { fields: "all" } +poolParameters + :: StakePoolsQueryArgument + -> QueryM (Either OgmiosDecodeError PoolParametersR) +poolParameters stakePools = ogmiosQueryParams "queryLedgerState/stakePools" + stakePools + +delegationsAndRewards + :: Array String -- ^ A list of reward account bech32 strings + -> QueryM (Either OgmiosDecodeError DelegationsAndRewardsR) +delegationsAndRewards rewardAccounts = ogmiosQueryParams + "queryLedgerState/rewardAccountSummaries" + { query: + { delegationsAndRewards: rewardAccounts } } -mempoolSnapshotSizeAndCapacityCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit MempoolSizeAndCapacity -mempoolSnapshotSizeAndCapacityCall _ = - mkOgmiosCallTypeNoArgs "sizeOfMempool" - -releaseMempoolCall - :: MempoolSnapshotAcquired -> JsonRpc2Call Unit ReleasedMempool -releaseMempoolCall _ = - mkOgmiosCallTypeNoArgs "releaseMempool" +evaluateTxOgmios + :: CborBytes -> AdditionalUtxoSet -> QueryM Provider.TxEvaluationR +evaluateTxOgmios cbor additionalUtxos = unwrap <$> ogmiosErrorHandlerWithArg + evaluateTx + (cbor /\ additionalUtxos) + where + evaluateTx + :: CborBytes /\ AdditionalUtxoSet + -> QueryM (Either OgmiosDecodeError OgmiosTxEvaluationR) + evaluateTx (cbor_ /\ utxoqr) = ogmiosQueryParams "evaluateTransaction" + { transaction: { cbor: byteArrayToHex $ unwrap cbor_ } + , additionalUtxo: utxoqr + } -------------------------------------------------------------------------------- -- 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" } - --------------------------------------------------------------------------------- --- 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 - :: TransactionHash - -> { result :: { transaction :: { id :: TransactionHash } } } -submitSuccessPartialResp txHash = - { "result": { "transaction": { "id": txHash } } } - -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 eraSummaries)) = - fromArray $ map encodeEraSummary eraSummaries - 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) - ----------------- 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 - -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) +ogmiosQueryNoParams + :: forall a + . DecodeOgmios a + => String + -> QueryM (Either OgmiosDecodeError a) +ogmiosQueryNoParams = flip ogmiosQueryParams {} + +ogmiosQueryParams + :: forall a p + . DecodeOgmios a + => EncodeAeson p + => String + -> p + -> QueryM (Either OgmiosDecodeError a) +ogmiosQueryParams method params = do 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 } - ----------------- TX EVALUATION QUERY RESPONSE & PARSING - -type OgmiosRedeemerPtr = { index :: UInt, purpose :: String } - -newtype OgmiosTxEvaluationR = OgmiosTxEvaluationR TxEvaluationR - -derive instance Newtype OgmiosTxEvaluationR _ -derive instance Generic OgmiosTxEvaluationR _ - -instance Show OgmiosTxEvaluationR 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 + body = Aeson.encodeAeson + { jsonrpc: "2.0" + , method + , params } + handleAffjaxOgmiosResponse <$> ogmiosPostRequest body + +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) -newtype OgmiosTxEvaluationResult = OgmiosTxEvaluationResult TxEvaluationResult - -derive instance Newtype OgmiosTxEvaluationResult _ -derive instance Generic OgmiosTxEvaluationResult _ - -instance Show OgmiosTxEvaluationResult where - show = genericShow - -instance DecodeAeson OgmiosTxEvaluationResult where - decodeAeson = aesonArray $ \array -> do - OgmiosTxEvaluationResult <<< 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 - -newtype OgmiosScriptFailure = OgmiosScriptFailure ScriptFailure - -derive instance Generic OgmiosScriptFailure _ -derive instance Newtype OgmiosScriptFailure _ - -instance Show OgmiosScriptFailure where - show = genericShow - -newtype OgmiosTxEvaluationFailure = - OgmiosTxEvaluationFailure TxEvaluationFailure - -derive instance Generic OgmiosTxEvaluationFailure _ -derive instance Newtype OgmiosTxEvaluationFailure _ - -instance Show OgmiosTxEvaluationFailure where - show = genericShow - -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 - 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 OgmiosTxEvaluationFailure where - decodeAeson aeson = OgmiosTxEvaluationFailure <$> 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 :: OgmiosScriptFailure } <- - decodeAeson elem - (_ /\ unwrap 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" +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" ] - , 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 - -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 + , content = Just $ Affjax.RequestBody.String $ stringifyAeson body + , responseFormat = Affjax.ResponseFormat.string } - 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")) + 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 = + handleAffjaxResponseGeneric + { 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 + } --- Helper that decodes a string -aesonString - :: forall (a :: Type) - . (String -> Either JsonDecodeError a) - -> Aeson - -> Either JsonDecodeError a -aesonString = caseAesonString (Left (TypeMismatch "Expected String")) +ogmiosErrorHandler + :: forall a m + . MonadAff m + => MonadThrow Error m + => m (Either OgmiosDecodeError a) + -> m a +ogmiosErrorHandler fun = fun >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + pure --- Helper that decodes a null -aesonNull - :: forall (a :: Type) - . Aeson - -> Either JsonDecodeError Unit -aesonNull = caseAesonNull (Left (TypeMismatch "Expected Null")) pure +ogmiosErrorHandlerWithArg + :: forall a m b + . MonadAff m + => MonadThrow Error m + => (a -> m (Either OgmiosDecodeError b)) + -> a + -> m b +ogmiosErrorHandlerWithArg fun arg = fun arg >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + pure diff --git a/src/Internal/QueryM/Ogmios/Mempool.purs b/src/Internal/QueryM/Ogmios/Mempool.purs new file mode 100644 index 0000000000..55a0a2ac5d --- /dev/null +++ b/src/Internal/QueryM/Ogmios/Mempool.purs @@ -0,0 +1,517 @@ +module Ctl.Internal.QueryM.Ogmios.Mempool + ( ReleasedMempool(ReleasedMempool) + , MempoolSizeAndCapacity(MempoolSizeAndCapacity) + , MempoolSnapshotAcquired + , MempoolTransaction(MempoolTransaction) + , HasTxR(HasTxR) + , MaybeMempoolTransaction(MaybeMempoolTransaction) + , acquireMempoolSnapshotCall + , mempoolSnapshotHasTxCall + , mempoolSnapshotNextTxCall + , mempoolSnapshotSizeAndCapacityCall + , releaseMempoolCall + , ListenerSet + , OgmiosListeners + , ListenerId + , mkOgmiosCallType + , OgmiosWebSocket + , WebSocket(WebSocket) + , listeners + , mkListenerSet + , defaultMessageListener + , mkOgmiosWebSocketAff + , mkRequestAff + , underlyingWebSocket + ) where + +import Prelude + +import Aeson + ( class DecodeAeson + , class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch, UnexpectedValue) + , caseAesonNull + , caseAesonObject + , caseAesonString + , decodeAeson + , getField + , parseJsonStringToAeson + , stringifyAeson + , (.:) + ) +import Cardano.Provider.TxEvaluation (OgmiosTxId) +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.Mempool.Dispatcher + ( DispatchError(JsonError) + , Dispatcher + , RequestBody + , WebsocketDispatch + , mkWebsocketDispatch + , newDispatcher + ) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket + ( JsWebSocket + , Url + , _mkWebSocket + , _onWsConnect + , _onWsError + , _onWsMessage + , _removeOnWsError + , _wsClose + , _wsFinalize + , _wsSend + ) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 + ( JsonRpc2Call + , JsonRpc2Request + , mkCallType + ) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 as JsonRpc2 +import Ctl.Internal.QueryM.Ogmios.Types + ( class DecodeOgmios + , OgmiosDecodeError + , decodeOgmios + , decodeResult + , ogmiosDecodeErrorToError + ) +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(Nothing, Just)) +import Data.Newtype (class Newtype, wrap) +import Data.Show.Generic (genericShow) +import Effect (Effect) +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 + +type Logger = LogLevel -> String -> Effect Unit + +-------------------------------------------------------------------------------- +-- Ogmios Local Tx Monitor Protocol +-------------------------------------------------------------------------------- + +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) + => DecodeOgmios o + => { method :: String, params :: i -> a } + -> 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 +-------------------------------------------------------------------------------- + +mkOgmiosWebSocketAff + :: Logger + -> String + -> Aff OgmiosWebSocket +mkOgmiosWebSocketAff logger serverUrl = do + lens <- liftEffect $ mkOgmiosWebSocketLens logger + makeAff $ mkServiceWebSocket lens serverUrl + +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..." + 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 + +-------------------------------------------------------------------------------- +-- `MkServiceWebSocketLens` for ogmios +-------------------------------------------------------------------------------- + +type MkServiceWebSocketLens (listeners :: Type) = + { serviceName :: String + , dispatcher :: Dispatcher + , logger :: Logger + , typedWebSocket :: JsWebSocket -> WebSocket listeners + } + +mkOgmiosWebSocketLens + :: Logger + -> Effect (MkServiceWebSocketLens OgmiosListeners) +mkOgmiosWebSocketLens logger = do + dispatcher <- newDispatcher + pure $ + let + ogmiosWebSocket :: JsWebSocket -> OgmiosWebSocket + ogmiosWebSocket ws = WebSocket ws + { acquireMempool: + mkListenerSet dispatcher + , releaseMempool: + mkListenerSet dispatcher + , mempoolHasTx: + mkListenerSet dispatcher + , mempoolNextTx: + mkListenerSet dispatcher + , mempoolSizeAndCapacity: + mkListenerSet dispatcher + } + + in + { serviceName: "ogmios" + , dispatcher + , logger + , typedWebSocket: ogmiosWebSocket + } + +-------------------------------------------------------------------------------- +-- ListenerSet +-------------------------------------------------------------------------------- + +type OgmiosListeners = + { acquireMempool :: ListenerSet Unit MempoolSnapshotAcquired + , releaseMempool :: ListenerSet Unit ReleasedMempool + , mempoolHasTx :: ListenerSet TransactionHash HasTxR + , mempoolNextTx :: ListenerSet Unit MaybeMempoolTransaction + , mempoolSizeAndCapacity :: ListenerSet Unit MempoolSizeAndCapacity + } + +-- 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. + } + +mkAddMessageListener + :: forall (response :: Type) + . DecodeOgmios response + => Dispatcher + -> ( ListenerId + -> (Either 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 + -> (ListenerId -> Effect Unit) +mkRemoveMessageListener dispatcher = + \reflection -> do + Ref.modify_ (Map.delete reflection) dispatcher + +-- 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) + . DecodeOgmios response + => Dispatcher + -> ListenerSet request response +mkListenerSet dispatcher = + { addMessageListener: + mkAddMessageListener dispatcher + , removeMessageListener: + mkRemoveMessageListener dispatcher + } + +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 + ) + _wsSend webSocket (logger Debug) sBody + -- Uncomment this code fragment to test `SubmitTx` request resend logic: + 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 + +-------------------------------------------------------------------------------- + +-- 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 + caseAesonNull (Left (TypeMismatch "Null")) pure $ 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 (caseAesonString (Left (TypeMismatch "String"))) released $ \s -> + if s == "mempool" then + pure $ ReleasedMempool + else + Left (UnexpectedValue $ Argonaut.encodeString s) + +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/Dispatcher.purs b/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs similarity index 74% rename from src/Internal/QueryM/Dispatcher.purs rename to src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs index 35f8874159..f1fb561a6a 100644 --- a/src/Internal/QueryM/Dispatcher.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/Dispatcher.purs @@ -1,33 +1,29 @@ -module Ctl.Internal.QueryM.Dispatcher +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.JsonRpc2 (parseJsonRpc2ResponseId) -import Ctl.Internal.QueryM.UniqueId (ListenerId) +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) import Effect.Ref (new, read) as Ref +type ListenerId = String + data DispatchError = JsonError JsonDecodeError -- Server response has been parsed succesfully, but it contains error @@ -74,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/src/Internal/JsWebSocket.js b/src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.js similarity index 100% rename from src/Internal/JsWebSocket.js rename to src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.js diff --git a/src/Internal/JsWebSocket.purs b/src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.purs similarity index 96% rename from src/Internal/JsWebSocket.purs rename to src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.purs index 52590c76e2..936d1abcba 100644 --- a/src/Internal/JsWebSocket.purs +++ b/src/Internal/QueryM/Ogmios/Mempool/JsWebSocket.purs @@ -1,4 +1,4 @@ -module Ctl.Internal.JsWebSocket +module Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket ( JsWebSocket , ListenerRef , Url diff --git a/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.js b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.js new file mode 100644 index 0000000000..a96dee7ac8 --- /dev/null +++ b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.js @@ -0,0 +1,5 @@ +import uniqid from "uniqid"; + +export function uniqueId(str) { + return () => uniqid(str); +} diff --git a/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs new file mode 100644 index 0000000000..0806709af7 --- /dev/null +++ b/src/Internal/QueryM/Ogmios/Mempool/JsonRpc2.purs @@ -0,0 +1,82 @@ +-- | Provides basics types and operations for working with JSON RPC protocol +-- | used by Ogmios +module Ctl.Internal.QueryM.Ogmios.Mempool.JsonRpc2 + ( JsonRpc2Call + , JsonRpc2Request + , buildRequest + , mkCallType + , parseJsonRpc2ResponseId + ) where + +import Prelude + +import Aeson + ( class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch) + , caseAesonObject + , encodeAeson + , getField + ) +import Data.Either (Either(Left)) +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) = + { jsonrpc :: String + , method :: String + , params :: a + , id :: String + } + +-- | 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 String +parseJsonRpc2ResponseId = + caseAesonObject (Left (TypeMismatch "Object")) $ flip getField "id" + diff --git a/src/Internal/QueryM/Ogmios/Types.purs b/src/Internal/QueryM/Ogmios/Types.purs new file mode 100644 index 0000000000..9aa1cc7fba --- /dev/null +++ b/src/Internal/QueryM/Ogmios/Types.purs @@ -0,0 +1,1103 @@ +-- | 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) + , OgmiosBlockHeaderHash(OgmiosBlockHeaderHash) + , OgmiosProtocolParameters(OgmiosProtocolParameters) + , PParamRational(PParamRational) + , PoolParameters + , PoolParametersR(PoolParametersR) + , AdditionalUtxoSet(AdditionalUtxoSet) + , OgmiosUtxoMap + , decodeResult + , decodeErrorOrResult + , decodeAesonJsonRpc2Response + , OgmiosError(OgmiosError) + , pprintOgmiosDecodeError + , ogmiosDecodeErrorToError + , decodeOgmios + , class DecodeOgmios + , OgmiosDecodeError + ( InvalidRpcError + , InvalidRpcResponse + , ErrorResponse + ) + , OgmiosEraSummaries(OgmiosEraSummaries) + , OgmiosSystemStart(OgmiosSystemStart) + , SubmitTxR(SubmitTxSuccess, SubmitFail) + , StakePoolsQueryArgument(StakePoolsQueryArgument) + , OgmiosTxEvaluationR(OgmiosTxEvaluationR) + , submitSuccessPartialResp + , parseIpv6String + , rationalToSubcoin + ) where + +import Prelude + +import Aeson + ( class DecodeAeson + , class EncodeAeson + , Aeson + , JsonDecodeError(TypeMismatch, MissingValue, AtKey) + , caseAesonString + , decodeAeson + , encodeAeson + , fromArray + , fromString + , getField + , getFieldOptional + , getFieldOptional' + , isNull + , printJsonDecodeError + , stringifyAeson + , (.:) + , (.:?) + ) +import Cardano.AsCbor (decodeCbor, encodeCbor) +import Cardano.Provider.TxEvaluation + ( ExecutionUnits + , OgmiosTxOut + , OgmiosTxOutRef + , RedeemerPointer + , ScriptFailure + ( InternalLedgerTypeConversionError + , NoCostModelForLanguage + , UnknownInputReferencedByRedeemer + , MissingRequiredDatums + , ExtraRedeemers + , NonScriptInputReferencedByRedeemer + , ValidatorFailed + , MissingRequiredScripts + ) + , TxEvaluationFailure(UnparsedError, AdditionalUtxoOverlap, ScriptFailures) + , TxEvaluationR(TxEvaluationR) + , TxEvaluationResult(TxEvaluationResult) + ) +import Cardano.Serialization.Lib (fromBytes, ipv4_new) +import Cardano.Types + ( 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.Coin (Coin(Coin)) +import Cardano.Types.CostModel (CostModel(CostModel)) +import Cardano.Types.Ed25519KeyHash (Ed25519KeyHash) +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.Ipv4 (Ipv4(Ipv4)) +import Cardano.Types.Ipv6 (Ipv6) +import Cardano.Types.NativeScript + ( NativeScript + ( ScriptPubkey + , ScriptAll + , ScriptAny + , ScriptNOfK + , TimelockStart + , TimelockExpiry + ) + ) +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.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 Ctl.Internal.Helpers (encodeMap, showWithParens) +import Ctl.Internal.Service.Helpers (aesonArray, aesonObject, aesonString) +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, length, replicate) as Array +import Data.Bifunctor (lmap) +import Data.ByteArray (byteArrayFromIntArray, byteArrayToHex, hexToByteArray) +import Data.Either (Either(Left, Right), either, note) +import Data.Foldable (fold, foldl) +import Data.Generic.Rep (class Generic) +import Data.Int (fromString) as Int +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), Replacement(Replacement)) +import Data.String (replaceAll) as String +import Data.String.Common (split) as String +import Data.String.Utils as StringUtils +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 +import Untagged.TypeCheck (class HasRuntimeType) +import Untagged.Union (type (|+|), toEither1) + +---------------- TX SUBMISSION QUERY RESPONSE & PARSING + +submitSuccessPartialResp + :: TransactionHash + -> { result :: { transaction :: { id :: TransactionHash } } } +submitSuccessPartialResp txHash = + { "result": { "transaction": { "id": txHash } } } + +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 eraSummaries)) = + fromArray $ map encodeEraSummary eraSummaries + 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) + +---------------- 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 + +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 ("50" <> 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 } + +---------------- TX EVALUATION QUERY RESPONSE & PARSING + +type OgmiosRedeemerPtr = { index :: UInt, purpose :: String } + +newtype OgmiosTxEvaluationR = OgmiosTxEvaluationR TxEvaluationR + +derive instance Newtype OgmiosTxEvaluationR _ +derive instance Generic OgmiosTxEvaluationR _ + +instance Show OgmiosTxEvaluationR 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 + +derive instance Newtype OgmiosTxEvaluationResult _ +derive instance Generic OgmiosTxEvaluationResult _ + +instance Show OgmiosTxEvaluationResult where + show = genericShow + +instance DecodeAeson OgmiosTxEvaluationResult where + decodeAeson = aesonArray $ \array -> do + OgmiosTxEvaluationResult <<< 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 + +newtype OgmiosScriptFailure = OgmiosScriptFailure ScriptFailure + +derive instance Generic OgmiosScriptFailure _ +derive instance Newtype OgmiosScriptFailure _ + +instance Show OgmiosScriptFailure where + show = genericShow + +newtype OgmiosTxEvaluationFailure = + OgmiosTxEvaluationFailure TxEvaluationFailure + +derive instance Generic OgmiosTxEvaluationFailure _ +derive instance Newtype OgmiosTxEvaluationFailure _ + +instance Show OgmiosTxEvaluationFailure where + show = genericShow + +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 + 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 OgmiosTxEvaluationFailure where + decodeAeson aeson = OgmiosTxEvaluationFailure <$> 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 :: OgmiosScriptFailure } <- + decodeAeson elem + (_ /\ unwrap 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 + +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 + +-- 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) + -- 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 _ + +instance Show OgmiosDecodeError where + show = genericShow + +pprintOgmiosDecodeError :: OgmiosDecodeError -> String +pprintOgmiosDecodeError (ErrorResponse err) = "Ogmios responded with error: " <> + maybe "" pprintOgmiosError 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 + +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 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 $ InvalidRpcResponse err + -- Got an expected error + _ /\ Just (Right x) -> pure x + -- Got an unexpected error + _ -> do + err :: Maybe OgmiosError <- sequence $ + lmap InvalidRpcError <<< 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 :: Maybe String + } + +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 <- getFieldOptional' o "id" + pure + { jsonrpc + , method + , result + , error + , id + } diff --git a/src/Internal/QueryM/Pools.purs b/src/Internal/QueryM/Pools.purs index 69346bfb96..9fb300c070 100644 --- a/src/Internal/QueryM/Pools.purs +++ b/src/Internal/QueryM/Pools.purs @@ -13,15 +13,17 @@ 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 (QueryM) import Ctl.Internal.QueryM.Ogmios as Ogmios +import Ctl.Internal.QueryM.Ogmios.Types + ( PoolParameters + , pprintOgmiosDecodeError + ) import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) import Data.ByteArray (byteArrayToHex) +import Data.Either (either) import Data.Map (Map) import Data.Map as Map import Data.Maybe (Maybe(Nothing, Just)) @@ -35,10 +37,10 @@ import Record.Builder (build, merge) getStakePools :: Maybe (Array PoolPubKeyHash) -> QueryM (Map PoolPubKeyHash PoolParameters) -getStakePools selected = unwrap <$> - mkOgmiosRequest Ogmios.queryStakePoolsCall - _.stakePools - (wrap selected) +getStakePools selected = + Ogmios.poolParameters (wrap selected) >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< unwrap) getPoolIds :: QueryM (Array PoolPubKeyHash) getPoolIds = (Map.toUnfoldableUnordered >>> map fst) <$> @@ -69,12 +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 +getValidatorHashDelegationsAndRewards skh = + Ogmios.delegationsAndRewards [ stringRep ] >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< Map.lookup byteHex <<< unwrap) where stringRep :: String stringRep = unsafePartial $ ScriptHash.toBech32Unsafe "script" $ unwrap skh @@ -85,11 +85,10 @@ getValidatorHashDelegationsAndRewards skh = do -- TODO: batched variant getPubKeyHashDelegationsAndRewards :: StakePubKeyHash -> QueryM (Maybe DelegationsAndRewards) -getPubKeyHashDelegationsAndRewards pkh = do - DelegationsAndRewardsR mp <- mkOgmiosRequest Ogmios.queryDelegationsAndRewards - _.delegationsAndRewards - [ stringRep ] - pure $ Map.lookup byteHex mp +getPubKeyHashDelegationsAndRewards pkh = + Ogmios.delegationsAndRewards [ stringRep ] >>= either + (throwError <<< error <<< pprintOgmiosDecodeError) + (pure <<< Map.lookup byteHex <<< unwrap) where stringRep :: String stringRep = unsafePartial diff --git a/src/Internal/ServerConfig.purs b/src/Internal/ServerConfig.purs index 8b42d91096..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.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/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/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/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/src/Internal/Types/Interval.purs b/src/Internal/Types/Interval.purs index a7fc5c3c24..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 (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 d3d06dc5f6..9e99c55c36 100644 --- a/test/Ogmios/Aeson.purs +++ b/test/Ogmios/Aeson.purs @@ -7,22 +7,19 @@ 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) -import Ctl.Internal.QueryM.JsonRpc2 +import Ctl.Internal.QueryM.Ogmios.Mempool (HasTxR, MempoolSizeAndCapacity) as Mempool +import Ctl.Internal.QueryM.Ogmios.Types ( class DecodeOgmios , OgmiosDecodeError(ErrorResponse) - , decodeOgmios - ) -import Ctl.Internal.QueryM.Ogmios - ( HasTxR , OgmiosTxEvaluationR , SubmitTxR - , aesonObject + , decodeOgmios ) -import Ctl.Internal.QueryM.Ogmios as O +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) @@ -66,8 +63,8 @@ tested = ) , ("evaluateTransaction" /\ check (Proxy :: _ OgmiosTxEvaluationR)) , ("submitTransaction" /\ check (Proxy :: _ SubmitTxR)) - , ("hasTransaction" /\ check (Proxy :: _ HasTxR)) - , ("sizeOfMempool" /\ check (Proxy :: _ 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/Ogmios/EvaluateTx.purs b/test/Ogmios/EvaluateTx.purs index 78012210b4..1ca1ca8499 100644 --- a/test/Ogmios/EvaluateTx.purs +++ b/test/Ogmios/EvaluateTx.purs @@ -2,7 +2,6 @@ module Test.Ctl.Ogmios.EvaluateTx (suite) where import Prelude -import Aeson (JsonDecodeError(TypeMismatch)) import Cardano.Provider.TxEvaluation ( ExecutionUnits , RedeemerPointer @@ -13,11 +12,12 @@ 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 - ( OgmiosDecodeError(ResultDecodingError) +import Ctl.Internal.QueryM.Ogmios.Types + ( OgmiosDecodeError(InvalidRpcResponse) + , OgmiosTxEvaluationR , decodeOgmios ) -import Ctl.Internal.QueryM.Ogmios (OgmiosTxEvaluationR) +import Data.Argonaut.Decode.Error (JsonDecodeError(TypeMismatch)) import Data.Either (Either(Left, Right)) import Data.Map as Map import Data.Maybe (fromJust) @@ -52,12 +52,14 @@ 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 (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)" diff --git a/test/Ogmios/GenerateFixtures.purs b/test/Ogmios/GenerateFixtures.purs index f1ae3eca67..a08d98db22 100644 --- a/test/Ogmios/GenerateFixtures.purs +++ b/test/Ogmios/GenerateFixtures.purs @@ -7,7 +7,18 @@ 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.Ogmios.Mempool + ( ListenerSet + , WebSocket(WebSocket) + , defaultMessageListener + , mkOgmiosCallType + , mkRequestAff + ) +import Ctl.Internal.QueryM.Ogmios.Mempool.Dispatcher + ( WebsocketDispatch + , mkWebsocketDispatch + ) +import Ctl.Internal.QueryM.Ogmios.Mempool.JsWebSocket ( _mkWebSocket , _onWsConnect , _onWsError @@ -15,20 +26,10 @@ import Ctl.Internal.JsWebSocket , _wsClose , _wsSend ) -import Ctl.Internal.QueryM - ( 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 Data.Either (Either(Left, Right)) +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)) import Data.Log.Level (LogLevel(Trace, Debug)) import Data.Map as Map import Data.Newtype (class Newtype, unwrap, wrap) @@ -72,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 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 324410a747..2a5db33993 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.Ogmios (getChainTip, submitTxOgmios) import Data.ByteArray (hexToByteArrayUnsafe) import Data.Either (Either(Left, Right)) import Data.Maybe (fromJust, isJust) 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 6edd6cb464..786fb96ed5 100644 --- a/test/Testnet/Contract/OgmiosMempool.purs +++ b/test/Testnet/Contract/OgmiosMempool.purs @@ -5,23 +5,58 @@ 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 - ( MempoolSizeAndCapacity(MempoolSizeAndCapacity) + ( MempoolM , acquireMempoolSnapshot , fetchMempoolTxs , mempoolSnapshotHasTx , mempoolSnapshotSizeAndCapacity , withMempoolSnapshot ) -import Contract.Scripts (validatorHash) +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 + (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 @@ -33,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 @@ -43,13 +80,16 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do + ws <- mkWebsocket validator <- InlineDatum.checkDatumIsInlineScript - let vhash = validatorHash validator + 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" @@ -62,18 +102,21 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do + ws <- mkWebsocket validator <- InlineDatum.checkDatumIsInlineScript - let vhash = validatorHash validator + 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 @@ -83,9 +126,11 @@ suite = group "Ogmios mempool test" do ] withWallets distribution \alice -> do withKeyWallet alice do + ws <- mkWebsocket validator <- InlineDatum.checkDatumIsInlineScript - let vhash = validatorHash validator + let vhash = PlutusScript.hash validator void $ InlineDatum.payToCheckDatumIsInline vhash MempoolSizeAndCapacity { numberOfTxs } <- - withMempoolSnapshot (mempoolSnapshotSizeAndCapacity) + runMempoolAction ws $ withMempoolSnapshot + (mempoolSnapshotSizeAndCapacity) numberOfTxs `shouldEqual` 1 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..832de7b223 100644 --- a/test/Types/Ipv6.purs +++ b/test/Types/Ipv6.purs @@ -5,27 +5,30 @@ 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.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))