From 96d82153d94471b531ce3a6dc103cf83170791f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Mon, 9 Dec 2024 16:25:38 +0100 Subject: [PATCH] Add MonadBlockchain instance to BlockfrostT --- src/blockfrost/lib/Convex/Blockfrost.hs | 58 ++++++++----- .../lib/Convex/Blockfrost/MonadBlockchain.hs | 81 +++++++++++-------- .../lib/Convex/Blockfrost/Orphans.hs | 11 ++- src/blockfrost/lib/Convex/Blockfrost/Types.hs | 57 +++++++++---- 4 files changed, 133 insertions(+), 74 deletions(-) diff --git a/src/blockfrost/lib/Convex/Blockfrost.hs b/src/blockfrost/lib/Convex/Blockfrost.hs index ecee0b81..0b352646 100644 --- a/src/blockfrost/lib/Convex/Blockfrost.hs +++ b/src/blockfrost/lib/Convex/Blockfrost.hs @@ -15,29 +15,33 @@ module Convex.Blockfrost( streamUtxos ) where -import qualified Blockfrost.Client as Client -import Blockfrost.Client.Types (BlockfrostClientT, BlockfrostError, - Project) -import qualified Blockfrost.Client.Types as Types -import qualified Cardano.Api as C -import Control.Monad ((>=>)) -import Control.Monad.Except (ExceptT (..), liftEither, - runExceptT) -import Control.Monad.IO.Class (MonadIO (..)) -import Convex.Blockfrost.Orphans () -import qualified Convex.Blockfrost.Types as Types -import Convex.Class (MonadUtxoQuery (..)) -import qualified Convex.Utxos as Utxos -import Data.Bifunctor (Bifunctor (..)) -import qualified Data.Set as Set -import qualified Streaming.Prelude as S -import Streaming.Prelude (Of, Stream) +import qualified Blockfrost.Client as Client +import Blockfrost.Client.Types (BlockfrostClientT, + BlockfrostError, Project) +import qualified Blockfrost.Client.Types as Types +import qualified Cardano.Api as C +import Control.Monad ((>=>)) +import Control.Monad.Except (liftEither, runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.State.Strict (StateT) +import qualified Control.Monad.State.Strict as State +import Convex.Blockfrost.MonadBlockchain (BlockfrostState) +import qualified Convex.Blockfrost.MonadBlockchain as MonadBlockchain +import Convex.Blockfrost.Orphans () +import qualified Convex.Blockfrost.Types as Types +import Convex.Class (MonadBlockchain (..), + MonadUtxoQuery (..)) +import qualified Convex.Utxos as Utxos +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.Set as Set +import qualified Streaming.Prelude as S +import Streaming.Prelude (Of, Stream) {-| Monad transformer that implements the @MonadBlockchain@ class using blockfrost's API -} -newtype BlockfrostT m a = BlockfrostT{ unBlockfrostT :: BlockfrostClientT m a } - deriving newtype (Functor, Applicative, Monad, MonadIO) +newtype BlockfrostT m a = BlockfrostT{ unBlockfrostT :: StateT BlockfrostState (BlockfrostClientT m) a } + deriving newtype (Functor, Applicative, Monad, MonadIO, Types.MonadBlockfrost) -- TODO: More instances (need to be defined on BlockfrostClientT') @@ -53,6 +57,17 @@ instance MonadIO m => MonadUtxoQuery (BlockfrostT m) where $ Utxos.fromList @C.ConwayEra $ fmap (second (, Nothing)) results' +instance MonadIO m => MonadBlockchain C.ConwayEra (BlockfrostT m) where + sendTx = MonadBlockchain.sendTxBlockfrost + utxoByTxIn = BlockfrostT . MonadBlockchain.getUtxoByTxIn + queryProtocolParameters = BlockfrostT MonadBlockchain.getProtocolParams + queryStakeAddresses s _ = BlockfrostT (MonadBlockchain.getStakeAddresses s) + queryStakePools = BlockfrostT MonadBlockchain.getStakePools + querySystemStart = BlockfrostT MonadBlockchain.getSystemStart + queryEraHistory = BlockfrostT MonadBlockchain.getEraHistory + querySlotNo = BlockfrostT MonadBlockchain.getSlotNo + queryNetworkId = BlockfrostT MonadBlockchain.getNetworkId + lookupUtxo :: Types.MonadBlockfrost m => Client.AddressUtxo -> m (Either Types.ScriptResolutionFailure (C.TxIn, C.TxOut C.CtxUTxO C.ConwayEra)) lookupUtxo addr = runExceptT $ do k <- either (Types.resolveScript >=> liftEither) pure (Types.addressUtxo @C.ConwayEra addr) @@ -68,4 +83,7 @@ streamUtxos a = {-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project' -} runBlockfrostT :: MonadIO m => Project -> BlockfrostT m a -> m (Either BlockfrostError a) -runBlockfrostT proj = Types.runBlockfrostClientT proj . unBlockfrostT +runBlockfrostT proj = + Types.runBlockfrostClientT proj + . flip State.evalStateT MonadBlockchain.emptyBlockfrostState + . unBlockfrostT diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index 7a9a879a..3838ecd4 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -1,13 +1,27 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-| blockfrost-based implementation of MonadBlockchain -} module Convex.Blockfrost.MonadBlockchain( - BlockfrostState(..) + BlockfrostState(..), + emptyBlockfrostState, + + -- * 'MonadBlockchain' related functions + sendTxBlockfrost, + getUtxoByTxIn, + getProtocolParams, + getStakeAddresses, + getStakePools, + getSystemStart, + getEraHistory, + getSlotNo, + getNetworkId ) where import Blockfrost.Client (AccountInfo (..), @@ -27,9 +41,8 @@ import Cardano.Api (ConwayEra, import Cardano.Api.NetworkId (fromNetworkMagic) import Cardano.Api.Shelley (CtxUTxO, LedgerProtocolParameters (..), - PoolId, - StakeCredential, - TxOut, UTxO) + PoolId, TxOut, + UTxO) import qualified Cardano.Api.Shelley as C import Cardano.Slotting.Time (SlotLength, SystemStart) @@ -49,10 +62,10 @@ import Data.Bifunctor (Bifunctor (second import qualified Data.ByteString.Lazy as BSL import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, + mapMaybe) import Data.Set (Set) import qualified Data.Set as Set -import Data.SOP.NonEmpty (NonEmpty (..)) import qualified Data.SOP.NonEmpty as NonEmpty import Data.Time.Clock (UTCTime, getCurrentTime) @@ -65,19 +78,6 @@ import qualified Ouroboros.Consensus.HardFork.History.Summary as Summary import Ouroboros.Network.Magic (NetworkMagic (..)) import qualified Streaming.Prelude as S --- TODO --- stake addresses - --- DONE --- protocol params --- slot no --- era history --- utxoByTxIn --- send Tx --- query network id --- stake pools --- system start - data BlockfrostState = BlockfrostState { bfsGenesis :: Maybe Genesis @@ -92,7 +92,7 @@ data BlockfrostState = , bfsProtocolParams :: Maybe (LedgerProtocolParameters ConwayEra) - , bfsStakeRewards :: Map StakeCredential (C.Quantity, Maybe PoolId) + , bfsStakeRewards :: Map C.StakeAddress (C.Quantity, Maybe PoolId) , bfsEraHistory :: Maybe C.EraHistory -- ^ Era history @@ -142,6 +142,7 @@ emptyBlockfrostState = , bfsTxInputs = Map.empty , bfsProtocolParams = Nothing , bfsEraHistory = Nothing + , bfsStakeRewards = Map.empty } getGenesis :: (MonadBlockfrost m, MonadState BlockfrostState m) => m Genesis @@ -211,10 +212,10 @@ of the current slot. -} getSlotNo :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (C.SlotNo, SlotLength, UTCTime) getSlotNo = do - (eraHistory@(C.EraHistory interpreter), systemStart) <- (,) <$> getEraHistory <*> getSystemStart + (eraHistory_@(C.EraHistory interpreter), systemStart) <- (,) <$> getEraHistory <*> getSystemStart Block{_blockSlot} <- Client.getLatestBlock let currentSlot = maybe (error "getSlotNo: Expected slot") Types.slot _blockSlot - let utctime = either (error . (<>) "getSlotNo: slotToUtcTime failed " . show) id (slotToUtcTime eraHistory systemStart currentSlot) + let utctime = either (error . (<>) "getSlotNo: slotToUtcTime failed " . show) id (slotToUtcTime eraHistory_ systemStart currentSlot) l = either (error . (<>) "getSlotNo: slotToSlotLength failed " . show) id (Qry.interpretQuery interpreter $ Qry.slotToSlotLength currentSlot) pure (currentSlot, l, utctime) @@ -226,10 +227,22 @@ getProtocolParams = do getOrRetrieve protocolParams $ LedgerProtocolParameters . Types.protocolParametersConway <$> Client.getLatestEpochProtocolParams --- getStakeAddresses :: (MonadBlockfrost m, MonadState BlockfrostState m) => Set C.StakeCredential -> m (Map C.StakeAddress C.Quantity, Map C.StakeAddress PoolId) -- ^ Get stake rewards --- getStakeAddresses = undefined +{-| Look up the stake rewards and delegation targets +-} +getStakeAddresses :: (MonadBlockfrost m, MonadState BlockfrostState m) => Set C.StakeCredential -> m (Map C.StakeAddress C.Quantity, Map C.StakeAddress PoolId) +getStakeAddresses credentials = do + entries <- + traverse (\cred -> C.StakeAddress <$> fmap C.toShelleyNetwork getNetworkId <*> pure (C.toShelleyStakeCredential cred)) (Set.toList credentials) + >>= traverse (\r -> (r,) <$> getStakeRewardsSingle r) + pure + ( Map.fromList $ fmap (second fst) entries + , Map.fromList $ mapMaybe (traverse snd) entries) + +getStakeRewardsSingle :: (MonadBlockfrost m, MonadState BlockfrostState m) => C.StakeAddress -> m (C.Quantity, Maybe PoolId) +getStakeRewardsSingle cred = getOrRetrieve (stakeRewards . at cred) (stakeRewardsForAddress cred) -getStakeRewardsSingle :: (MonadBlockfrost m, MonadState BlockfrostState m) => C.StakeCredential -> m (C.Quantity, Maybe PoolId) -getStakeRewardsSingle cred = getOrRetrieve (stakeRewards . at cred) $ do - AccountInfo{_accountInfoPoolId, _accountInfoWithdrawableAmount} <- Client.getAccount (_ cred) - undefined +stakeRewardsForAddress :: MonadBlockfrost m => C.StakeAddress -> m (C.Quantity, Maybe PoolId) +stakeRewardsForAddress addr = do + AccountInfo{_accountInfoPoolId, _accountInfoControlledAmount} <- Client.getAccount (Types.fromStakeAddress addr) + pure ( C.lovelaceToQuantity $ Types.toLovelace _accountInfoControlledAmount + , fmap Types.poolId _accountInfoPoolId) diff --git a/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs b/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs index 38ca924b..b0656c68 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs @@ -7,10 +7,15 @@ module Convex.Blockfrost.Orphans( ) where -import Blockfrost.Client.Types (MonadBlockfrost (..)) -import Control.Monad.Except (ExceptT (..)) -import Control.Monad.Trans.Class (MonadTrans (..)) +import Blockfrost.Client.Types (MonadBlockfrost (..)) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.State.Strict (StateT) +import Control.Monad.Trans.Class (MonadTrans (..)) instance MonadBlockfrost m => MonadBlockfrost (ExceptT e m) where liftBlockfrostClient = lift . liftBlockfrostClient getConf = lift getConf + +instance MonadBlockfrost m => MonadBlockfrost (StateT s m) where + liftBlockfrostClient = lift . liftBlockfrostClient + getConf = lift getConf diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index e7eadd35..7eb4617d 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -33,6 +33,7 @@ module Convex.Blockfrost.Types( decodeTransactionCBOR, -- * Payment credential fromPaymentCredential, + fromStakeAddress, -- * Genesis related systemStart, -- * Misc. @@ -86,10 +87,8 @@ import qualified Cardano.Ledger.Babbage.PParams as L import qualified Cardano.Ledger.BaseTypes as BaseTypes import Cardano.Ledger.Binary.Encoding (EncCBOR) import qualified Cardano.Ledger.Binary.Version as Version -import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..)) import qualified Cardano.Ledger.Conway.PParams as L -import Cardano.Ledger.Core (PParams, - downgradePParams) +import Cardano.Ledger.Core (PParams) import qualified Cardano.Ledger.Plutus.CostModels as CostModels import qualified Cardano.Ledger.Plutus.Language as Plutus.Language import Cardano.Slotting.Slot (EpochSize (..)) @@ -105,7 +104,6 @@ import Control.Monad.Except (MonadError (..) import Control.Monad.Trans.Class (lift) import qualified Convex.CardanoApi.Lenses as L import Convex.Utils (inBabbage) -import Data.Bifunctor (Bifunctor (..)) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as BSL import Data.Coerce (Coercible, @@ -129,7 +127,6 @@ import Ouroboros.Consensus.HardFork.History.Summary (Bound (..), EraEnd (..), EraSummary (..)) import Ouroboros.Consensus.Shelley.Eras (StandardConway) -import qualified Ouroboros.Consensus.Shelley.Eras as Ledger.Eras import qualified Streaming.Prelude as S import Streaming.Prelude (Of, Stream) @@ -159,8 +156,10 @@ hexTextToByteString t = quantity :: Quantity -> Natural quantity (Quantity n) = fromInteger n +-- pool1axzm26vduyuxgw0x9ddh4vkvn7q5hyd558l0t9c08p556lf2zaj poolId :: PoolId -> C.PoolId -poolId = textToIsString +poolId (PoolId text) = + either (error . show) id $ C.deserialiseFromBech32 (proxyToAsType $ Proxy @(C.Hash C.StakePoolKey)) text toAssetId :: Amount -> (C.AssetId, C.Quantity) toAssetId = \case @@ -184,29 +183,53 @@ toAddress (Address text) = C.deserialiseAddress (C.proxyToAsType Proxy) text -- See https://github.com/blockfrost/blockfrost-haskell/issues/68 fromPaymentCredential :: C.PaymentCredential -> Address fromPaymentCredential = \case - C.PaymentCredentialByKey key -> Address $ C.serialiseToBech32 $ CustomBech32 key - C.PaymentCredentialByScript script -> Address $ C.serialiseToBech32 $ CustomBech32 script + C.PaymentCredentialByKey key -> Address $ C.serialiseToBech32 $ CustomBech32Payment key + C.PaymentCredentialByScript script -> Address $ C.serialiseToBech32 $ CustomBech32Payment script -newtype CustomBech32 a = CustomBech32 a -instance C.HasTypeProxy a => C.HasTypeProxy (CustomBech32 a) where - newtype AsType (CustomBech32 a) = CustomBech32Type (AsType a) - proxyToAsType _proxy = CustomBech32Type (proxyToAsType Proxy) +newtype CustomBech32Payment a = CustomBech32Payment a -instance C.SerialiseAsRawBytes a => C.SerialiseAsRawBytes (CustomBech32 a) where - serialiseToRawBytes (CustomBech32 a) = C.serialiseToRawBytes a - deserialiseFromRawBytes _asType = fmap CustomBech32 . C.deserialiseFromRawBytes (proxyToAsType Proxy) +instance C.HasTypeProxy a => C.HasTypeProxy (CustomBech32Payment a) where + newtype AsType (CustomBech32Payment a) = CustomBech32PaymentType (AsType a) + proxyToAsType _proxy = CustomBech32PaymentType (proxyToAsType Proxy) + +instance C.SerialiseAsRawBytes a => C.SerialiseAsRawBytes (CustomBech32Payment a) where + serialiseToRawBytes (CustomBech32Payment a) = C.serialiseToRawBytes a + deserialiseFromRawBytes _asType = fmap CustomBech32Payment . C.deserialiseFromRawBytes (proxyToAsType Proxy) -- The following two instances of @SerialiseAsBech32@ are used for generating payment credential queries that blockfrost understands -- See: https://github.com/blockfrost/blockfrost-utils/blob/master/src/validation.ts#L109-L128 -instance C.SerialiseAsBech32 (CustomBech32 (C.Hash C.PaymentKey)) where +instance C.SerialiseAsBech32 (CustomBech32Payment (C.Hash C.PaymentKey)) where bech32PrefixFor _ = "addr_vkh" bech32PrefixesPermitted _ = ["addr_vkh"] -instance C.SerialiseAsBech32 (CustomBech32 C.ScriptHash) where +instance C.SerialiseAsBech32 (CustomBech32Payment C.ScriptHash) where bech32PrefixFor _ = "script" bech32PrefixesPermitted _ = ["script"] +fromStakeAddress :: C.StakeAddress -> Address +fromStakeAddress = Address . C.serialiseToBech32 + +newtype CustomBech32Stake a = CustomBech32Stake a + +instance C.HasTypeProxy a => C.HasTypeProxy (CustomBech32Stake a) where + newtype AsType (CustomBech32Stake a) = CustomBech32StakeType (AsType a) + proxyToAsType _proxy = CustomBech32StakeType (proxyToAsType Proxy) + +instance C.SerialiseAsRawBytes a => C.SerialiseAsRawBytes (CustomBech32Stake a) where + serialiseToRawBytes (CustomBech32Stake a) = C.serialiseToRawBytes a + deserialiseFromRawBytes _asType = fmap CustomBech32Stake . C.deserialiseFromRawBytes (proxyToAsType Proxy) + +-- The following two instances of @SerialiseAsBech32@ are used for generating payment credential queries that blockfrost understands +-- See: https://github.com/blockfrost/blockfrost-utils/blob/master/src/validation.ts#L109-L128 +instance C.SerialiseAsBech32 (CustomBech32Stake (C.Hash C.StakeKey)) where + bech32PrefixFor _ = "stake" + bech32PrefixesPermitted _ = ["stake"] + +instance C.SerialiseAsBech32 (CustomBech32Stake C.ScriptHash) where + bech32PrefixFor _ = "stake" + bech32PrefixesPermitted _ = ["stake"] + toStakeAddress :: Address -> Maybe C.StakeAddress toStakeAddress (Address text) = C.deserialiseAddress (C.proxyToAsType Proxy) text