Use Kupmios backend provider

Author: marcusbfs

packages.dhall

@@ -1,5 +1,89 @@
 let upstream =
     -- https://github.com/mlabs-haskell/purescript-cardano-package-set
-      https://raw.githubusercontent.com/mlabs-haskell/purescript-cardano-package-set/v1.2.0/packages.dhall sha256:1879aeee12ef41d5f39ed8b530efa817c747366553b2fc90981ad4e8c21fc5d8
+      https://raw.githubusercontent.com/mlabs-haskell/purescript-cardano-package-set/v1.2.0/packages.dhall
+        sha256:1879aeee12ef41d5f39ed8b530efa817c747366553b2fc90981ad4e8c21fc5d8
 
-in  upstream
+let additions =
+      { cardano-kupmios-provider =
+        { dependencies =
+          [ "aeson"
+          , "aff"
+          , "aff-promise"
+          , "affjax"
+          , "arrays"
+          , "bifunctors"
+          , "bytearrays"
+          , "cardano-key-wallet"
+          , "cardano-provider"
+          , "cardano-serialization-lib"
+          , "cardano-types"
+          , "console"
+          , "control"
+          , "datetime"
+          , "effect"
+          , "either"
+          , "exceptions"
+          , "foldable-traversable"
+          , "foreign-object"
+          , "formatters"
+          , "http-methods"
+          , "integers"
+          , "js-bigints"
+          , "js-date"
+          , "lists"
+          , "maybe"
+          , "monad-logger"
+          , "newtype"
+          , "ordered-collections"
+          , "parallel"
+          , "partial"
+          , "prelude"
+          , "profunctor-lenses"
+          , "record"
+          , "strings"
+          , "stringutils"
+          , "tailrec"
+          , "these"
+          , "transformers"
+          , "tuples"
+          , "uint"
+          , "untagged-union"
+          ]
+        , repo =
+            "https://github.com/mlabs-haskell/purescript-cardano-kupmios-provider"
+        , version = "bcaadf9b37c4c9290b77579d212fd37b06730632"
+        }
+      , cardano-ogmios-mempool-provider =
+        { dependencies =
+          [ "aeson"
+          , "aff"
+          , "argonaut-codecs"
+          , "arrays"
+          , "bifunctors"
+          , "bytearrays"
+          , "cardano-kupmios-provider"
+          , "cardano-provider"
+          , "cardano-types"
+          , "control"
+          , "effect"
+          , "either"
+          , "exceptions"
+          , "foldable-traversable"
+          , "foreign-object"
+          , "lists"
+          , "maybe"
+          , "monad-logger"
+          , "newtype"
+          , "ordered-collections"
+          , "prelude"
+          , "record"
+          , "refs"
+          , "transformers"
+          ]
+        , repo =
+            "https://github.com/mlabs-haskell/purescript-cardano-ogmios-mempool-provider"
+        , version = "788cb701e5aaad1e299a118eb07a4f4fc6d5c734"
+        }
+      }
+
+in  upstream // additions

spago-packages.nix

@@ -7,13 +7,13 @@ module Contract.Backend.Ogmios
 import Prelude
 
 import Cardano.Kupmios.Ogmios (submitTxOgmios) as Ogmios
-import Cardano.Kupmios.Ogmios.Pools (getPoolParameters) as QueryM
+import Cardano.Kupmios.Ogmios.Pools (getPoolParameters) as KupmiosM
 import Cardano.Kupmios.Ogmios.Types (SubmitTxR)
 import Cardano.Types (PoolParams, PoolPubKeyHash)
 import Cardano.Types.CborBytes (CborBytes)
 import Cardano.Types.TransactionHash (TransactionHash)
 import Contract.Monad (Contract)
-import Ctl.Internal.Contract.Monad (wrapQueryM)
+import Ctl.Internal.Contract.Monad (wrapKupmiosM)
 
 -- | **This function can only run with Ogmios backend**
 -- |
@@ -22,8 +22,8 @@ import Ctl.Internal.Contract.Monad (wrapQueryM)
 getPoolParameters
   :: PoolPubKeyHash
   -> Contract PoolParams
-getPoolParameters = wrapQueryM <<< QueryM.getPoolParameters
+getPoolParameters = wrapKupmiosM <<< KupmiosM.getPoolParameters
 
 -- | Error returning variant
 submitTxE :: TransactionHash -> CborBytes -> Contract SubmitTxR
-submitTxE txhash cbor = wrapQueryM $ Ogmios.submitTxOgmios txhash cbor
+submitTxE txhash cbor = wrapKupmiosM $ Ogmios.submitTxOgmios txhash cbor

src/Contract/Backend/Ogmios.purs

@@ -9,8 +9,8 @@ module Ctl.Internal.Contract.Monad
   , mkContractEnv
   , runContract
   , runContractInEnv
-  , runQueryM
-  , wrapQueryM
+  , runKupmiosM
+  , wrapKupmiosM
   , stopContractEnv
   , withContractEnv
   , buildBackend
@@ -27,12 +27,12 @@ import Cardano.Blockfrost.Service
   , runBlockfrostServiceM
   )
 import Cardano.Blockfrost.Service as Blockfrost
+import Cardano.Kupmios.KupmiosM (KupmiosEnv, KupmiosM)
 import Cardano.Kupmios.Ogmios (getProtocolParameters, getSystemStartTime)
 import Cardano.Kupmios.Ogmios.Types
   ( OgmiosDecodeError
   , pprintOgmiosDecodeError
   )
-import Cardano.Kupmios.QueryM (QueryEnv, QueryM)
 import Cardano.Provider.Error (ClientError)
 import Cardano.Provider.Type (Provider)
 import Cardano.Types (NetworkId(TestnetId, MainnetId), TransactionHash, UtxoMap)
@@ -202,12 +202,12 @@ mkProvider
 mkProvider params providerBackend =
   case providerBackend of
     CtlBackend ctlBackend _ ->
-      providerForCtlBackend runQueryM params ctlBackend
+      providerForCtlBackend runKupmiosM params ctlBackend
     BlockfrostBackend blockfrostBackend Nothing -> do
       providerForBlockfrostBackend params blockfrostBackend
     BlockfrostBackend blockfrostBackend (Just ctlBackend) -> do
       providerForSelfHostedBlockfrostBackend params blockfrostBackend
-        runQueryM
+        runKupmiosM
         ctlBackend
 
 -- | Initializes a `Contract` environment. Does not ensure finalization.
@@ -287,11 +287,11 @@ getLedgerConstants params = case _ of
         , suppressLogs: true
         }
     pparams <- unwrap <$>
-      ( runQueryM logParams ctlBackend getProtocolParameters >>=
+      ( runKupmiosM logParams ctlBackend getProtocolParameters >>=
           throwOnLeft
       )
     systemStart <- unwrap <$>
-      ( runQueryM logParams ctlBackend getSystemStartTime >>=
+      ( runKupmiosM logParams ctlBackend getSystemStartTime >>=
           throwOnLeft
       )
     pure { pparams, systemStart }
@@ -433,30 +433,30 @@ type ContractParams =
   }
 
 --------------------------------------------------------------------------------
--- QueryM
+-- KupmiosM
 --------------------------------------------------------------------------------
 
-wrapQueryM :: forall (a :: Type). QueryM a -> Contract a
-wrapQueryM qm = do
+wrapKupmiosM :: forall (a :: Type). KupmiosM a -> Contract a
+wrapKupmiosM qm = do
   backend <- asks _.backend
   ctlBackend <-
     getCtlBackend backend
       # liftM (error "Operation only supported on CTL backend")
   contractEnv <- ask
-  liftAff $ runQueryM contractEnv ctlBackend qm
+  liftAff $ runKupmiosM contractEnv ctlBackend qm
 
-runQueryM
+runKupmiosM
   :: forall (a :: Type) (rest :: Row Type)
    . LogParams rest
   -> CtlBackend
-  -> QueryM a
+  -> KupmiosM a
   -> Aff a
-runQueryM params ctlBackend =
-  flip runReaderT (mkQueryEnv params ctlBackend) <<< unwrap
+runKupmiosM params ctlBackend =
+  flip runReaderT (mkKupmiosEnv params ctlBackend) <<< unwrap
 
-mkQueryEnv
-  :: forall (rest :: Row Type). LogParams rest -> CtlBackend -> QueryEnv
-mkQueryEnv params ctlBackend =
+mkKupmiosEnv
+  :: forall (rest :: Row Type). LogParams rest -> CtlBackend -> KupmiosEnv
+mkKupmiosEnv params ctlBackend =
   { config:
       { ogmiosConfig: ctlBackend.ogmiosConfig
       , kupoConfig: ctlBackend.kupoConfig

src/Internal/Contract/Monad.purs

@@ -4,96 +4,29 @@ module Ctl.Internal.Contract.Provider
   , providerForSelfHostedBlockfrostBackend
   ) where
 
-import Prelude
-
-import Cardano.AsCbor (encodeCbor)
 import Cardano.Blockfrost.BlockfrostBackend (BlockfrostBackend)
 import Cardano.Blockfrost.Provider (providerForBlockfrostBackend) as Blockfrost
-import Cardano.Blockfrost.Service
-  ( BlockfrostServiceM
-  , runBlockfrostServiceM
-  )
-import Cardano.Kupmios.Kupo
-  ( getDatumByHash
-  , getOutputAddressesByTxHash
-  , getScriptByHash
-  , getTxAuxiliaryData
-  , getUtxoByOref
-  , isTxConfirmed
-  , utxosAt
-  ) as Kupo
-import Cardano.Kupmios.Ogmios
-  ( evaluateTxOgmios
-  , getChainTip
-  , submitTxOgmios
-  ) as Ogmios
-import Cardano.Kupmios.Ogmios.CurrentEpoch (getCurrentEpoch) as Ogmios
-import Cardano.Kupmios.Ogmios.EraSummaries (getEraSummaries) as Ogmios
-import Cardano.Kupmios.Ogmios.Pools
-  ( getPoolIds
-  , getPubKeyHashDelegationsAndRewards
-  , getValidatorHashDelegationsAndRewards
-  ) as Ogmios
-import Cardano.Kupmios.Ogmios.Types (SubmitTxR(SubmitFail, SubmitTxSuccess))
-import Cardano.Kupmios.QueryM (QueryM)
-import Cardano.Provider.Error (ClientError(ClientOtherError))
+import Cardano.Blockfrost.Service (BlockfrostServiceM, runBlockfrostServiceM)
+import Cardano.Kupmios.KupmiosM (KupmiosM)
+import Cardano.Kupmios.Provider as Kupmios
 import Cardano.Provider.Type (Provider)
-import Cardano.Types.Transaction (hash) as Transaction
-import Contract.Log (logDebug')
 import Ctl.Internal.Contract.LogParams (LogParams)
 import Ctl.Internal.Contract.ProviderBackend (CtlBackend)
 import Ctl.Internal.Helpers (logWithLevel)
-import Data.Either (Either(Left, Right))
-import Data.Maybe (fromMaybe, isJust)
-import Data.Newtype (unwrap, wrap)
+import Data.Maybe (fromMaybe)
 import Effect.Aff (Aff)
 
 providerForCtlBackend
   :: forall rest
-   . (forall (a :: Type). LogParams rest -> CtlBackend -> QueryM a -> Aff a)
+   . (forall (a :: Type). LogParams rest -> CtlBackend -> KupmiosM a -> Aff a)
   -> LogParams rest
   -> CtlBackend
   -> Provider
-providerForCtlBackend runQueryM params backend =
-  { getDatumByHash: runQueryM' <<< Kupo.getDatumByHash
-  , getScriptByHash: runQueryM' <<< Kupo.getScriptByHash
-  , getUtxoByOref: runQueryM' <<< Kupo.getUtxoByOref
-  , getOutputAddressesByTxHash: runQueryM' <<< Kupo.getOutputAddressesByTxHash
-  , doesTxExist: runQueryM' <<< map (map isJust) <<< Kupo.isTxConfirmed
-  , getTxAuxiliaryData: runQueryM' <<< Kupo.getTxAuxiliaryData
-  , utxosAt: runQueryM' <<< Kupo.utxosAt
-  , 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 <- Ogmios.submitTxOgmios txHash txCborBytes
-      pure $ case result of
-        SubmitTxSuccess th -> do
-          if th == txHash then Right th
-          else Left
-            ( ClientOtherError
-                "Computed TransactionHash is not equal to the one returned by Ogmios, please report as bug!"
-            )
-        SubmitFail err -> Left $ ClientOtherError $ show err
-  , 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'
-        (Ogmios.getPubKeyHashDelegationsAndRewards pubKeyHash)
-  , getValidatorHashDelegationsAndRewards: \_ validatorHash ->
-      Right <$> runQueryM'
-        (Ogmios.getValidatorHashDelegationsAndRewards $ wrap validatorHash)
-  }
-
+providerForCtlBackend runKupmiosM params backend =
+  Kupmios.providerForKupmiosBackend runKupmiosM'
   where
-  runQueryM' :: forall (a :: Type). QueryM a -> Aff a
-  runQueryM' = runQueryM params backend
+  runKupmiosM' :: forall (a :: Type). KupmiosM a -> Aff a
+  runKupmiosM' = runKupmiosM params backend
 
 providerForBlockfrostBackend
   :: forall rest. LogParams rest -> BlockfrostBackend -> Provider
@@ -109,18 +42,18 @@ providerForSelfHostedBlockfrostBackend
   :: forall rest
    . LogParams rest
   -> BlockfrostBackend
-  -> (forall (a :: Type). LogParams rest -> CtlBackend -> QueryM a -> Aff a)
+  -> (forall (a :: Type). LogParams rest -> CtlBackend -> KupmiosM a -> Aff a)
   -> CtlBackend
   -> Provider
 providerForSelfHostedBlockfrostBackend
   params
   blockfrostBackend
-  runQueryM
+  runKupmiosM
   ctlBackend =
   let
     blockfrostProvider = providerForBlockfrostBackend params
       blockfrostBackend
-    ctlProvider = providerForCtlBackend runQueryM params ctlBackend
+    ctlProvider = providerForCtlBackend runKupmiosM params ctlBackend
   in
     blockfrostProvider
       { evaluateTx = ctlProvider.evaluateTx