From 6c809eba16e4513865d19573ad87ea7b25dedd17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Tue, 3 Dec 2024 12:11:45 +0100 Subject: [PATCH 1/8] WIP --- src/blockfrost/convex-blockfrost.cabal | 3 + .../lib/Convex/Blockfrost/MonadBlockchain.hs | 55 +++++++++++++++++++ src/blockfrost/lib/Convex/Blockfrost/Types.hs | 13 ++++- 3 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs diff --git a/src/blockfrost/convex-blockfrost.cabal b/src/blockfrost/convex-blockfrost.cabal index 3ddc8b32..06e90767 100644 --- a/src/blockfrost/convex-blockfrost.cabal +++ b/src/blockfrost/convex-blockfrost.cabal @@ -30,6 +30,7 @@ library hs-source-dirs: lib exposed-modules: Convex.Blockfrost + Convex.Blockfrost.MonadBlockchain Convex.Blockfrost.Types build-depends: base >= 4.14 && < 5, @@ -42,6 +43,7 @@ library cardano-api, cardano-api:internal, cardano-ledger-binary, + cardano-slotting, convex-base, convex-optics, safe-money, @@ -49,6 +51,7 @@ library containers, transformers, streaming, + time, lens test-suite convex-blockfrost-test diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs new file mode 100644 index 00000000..2105a075 --- /dev/null +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-| blockfrost-based implementation of MonadBlockchain +-} +module Convex.Blockfrost.MonadBlockchain( + BlockfrostState(..) +) where + +import qualified Blockfrost.Client.Cardano.Ledger as Client +import Blockfrost.Client.Types (MonadBlockfrost (..)) +import Blockfrost.Types.Cardano.Genesis (Genesis) +import Cardano.Api (NetworkId) +import Cardano.Slotting.Time (SystemStart) +import Control.Lens (makeLensesFor, use, (?=)) +import Control.Monad.State (MonadState) +import qualified Convex.Blockfrost.Types as Types + +-- send Tx +-- utxoByTxIn +-- protocol params +-- stake addresses +-- stake pools +-- era history +-- slot no +-- query network id + +data BlockfrostState = + BlockfrostState + { bfsGenesis :: Maybe Genesis + } + +makeLensesFor + [ ("bfsGenesis", "genesis") + ] + ''BlockfrostState + +emptyBlockfrostState :: BlockfrostState +emptyBlockfrostState = + BlockfrostState + { bfsGenesis = Nothing + } + +getSystemStart :: (MonadBlockfrost m, MonadState BlockfrostState m) => m SystemStart +getSystemStart = use genesis >>= \case + Just g -> pure (Types.systemStart g) + Nothing -> do + k <- Client.getLedgerGenesis + genesis ?= k + pure (Types.systemStart k) + +getNetworkId :: (MonadBlockfrost m, MonadState BlockfrostState m) => m NetworkId +getNetworkId = undefined + +-- Cardano.Api.NetworkId.fromNetworkMagic +-- "network_magic": 764824073 (mainnet) \ No newline at end of file diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index 367a48f8..be04bfec 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -27,7 +27,9 @@ module Convex.Blockfrost.Types( -- * CBOR toCBORString, -- * Payment credential - fromPaymentCredential + fromPaymentCredential, + -- * Genesis related + systemStart ) where import qualified Blockfrost.Client.Cardano.Scripts as Client @@ -43,6 +45,8 @@ import Blockfrost.Types.Shared.Ada (Lovelaces) import Blockfrost.Types.Shared.Address (Address (..)) import Blockfrost.Types.Shared.Amount (Amount (..)) import Blockfrost.Types.Shared.CBOR (CBORString (..)) +import Cardano.Slotting.Time (SystemStart(..)) +import Blockfrost.Types.Cardano.Genesis (Genesis(..)) import Blockfrost.Types.Shared.DatumHash (DatumHash (..)) import Blockfrost.Types.Shared.PolicyId (PolicyId (..)) import Blockfrost.Types.Shared.Quantity (Quantity (..)) @@ -51,6 +55,7 @@ import Blockfrost.Types.Shared.TxHash (TxHash (..)) import Cardano.Api (HasTypeProxy (..)) import qualified Cardano.Api.Ledger as C.Ledger import Cardano.Api.SerialiseBech32 (SerialiseAsBech32 (..)) +import Data.Time.Clock.POSIX qualified as Clock import Cardano.Api.SerialiseUsing (UsingRawBytesHex (..)) import Cardano.Api.Shelley (Lovelace) import qualified Cardano.Api.Shelley as C @@ -253,3 +258,9 @@ addressUtxo AddressUtxo{_addressUtxoAddress, _addressUtxoAmount, _addressUtxoDat -} toCBORString :: EncCBOR v => v -> CBORString toCBORString = CBORString . BSL.fromStrict . C.Ledger.serialize' Version.shelleyProtVer + +{-| The 'SystemStart' value +-} +systemStart :: Genesis -> SystemStart +systemStart = + SystemStart . Clock.posixSecondsToUTCTime . _genesisSystemStart \ No newline at end of file From ac8c981442dc1c47a28ba5598820630cbbbf7a29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Wed, 4 Dec 2024 10:01:01 +0100 Subject: [PATCH 2/8] More functions for MonadBlockchain --- src/blockfrost/convex-blockfrost.cabal | 4 +- src/blockfrost/lib/Convex/Blockfrost.hs | 21 +-- .../lib/Convex/Blockfrost/MonadBlockchain.hs | 152 +++++++++++++++--- .../lib/Convex/Blockfrost/Orphans.hs | 16 ++ src/blockfrost/lib/Convex/Blockfrost/Types.hs | 59 +++++-- 5 files changed, 201 insertions(+), 51 deletions(-) create mode 100644 src/blockfrost/lib/Convex/Blockfrost/Orphans.hs diff --git a/src/blockfrost/convex-blockfrost.cabal b/src/blockfrost/convex-blockfrost.cabal index 06e90767..7df598ef 100644 --- a/src/blockfrost/convex-blockfrost.cabal +++ b/src/blockfrost/convex-blockfrost.cabal @@ -31,6 +31,7 @@ library exposed-modules: Convex.Blockfrost Convex.Blockfrost.MonadBlockchain + Convex.Blockfrost.Orphans Convex.Blockfrost.Types build-depends: base >= 4.14 && < 5, @@ -52,7 +53,8 @@ library transformers, streaming, time, - lens + lens, + ouroboros-network-api test-suite convex-blockfrost-test import: lang diff --git a/src/blockfrost/lib/Convex/Blockfrost.hs b/src/blockfrost/lib/Convex/Blockfrost.hs index 2ba4cd61..ecee0b81 100644 --- a/src/blockfrost/lib/Convex/Blockfrost.hs +++ b/src/blockfrost/lib/Convex/Blockfrost.hs @@ -6,8 +6,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} --- Need this because of missing instances for BlockfrostClientT -{-# OPTIONS_GHC -Wno-orphans #-} {-| Blockfrost-backed implementation of @MonadBlockchain@ -} module Convex.Blockfrost( @@ -19,14 +17,14 @@ module Convex.Blockfrost( import qualified Blockfrost.Client as Client import Blockfrost.Client.Types (BlockfrostClientT, BlockfrostError, - MonadBlockfrost (..), Project) + 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 Control.Monad.Trans.Class (MonadTrans (..)) +import Convex.Blockfrost.Orphans () import qualified Convex.Blockfrost.Types as Types import Convex.Class (MonadUtxoQuery (..)) import qualified Convex.Utxos as Utxos @@ -41,10 +39,6 @@ class using blockfrost's API newtype BlockfrostT m a = BlockfrostT{ unBlockfrostT :: BlockfrostClientT m a } deriving newtype (Functor, Applicative, Monad, MonadIO) -instance MonadBlockfrost m => MonadBlockfrost (ExceptT e m) where - liftBlockfrostClient = lift . liftBlockfrostClient - getConf = lift getConf - -- TODO: More instances (need to be defined on BlockfrostClientT') instance MonadIO m => MonadUtxoQuery (BlockfrostT m) where @@ -69,16 +63,7 @@ lookupUtxo addr = runExceptT $ do streamUtxos :: Types.MonadBlockfrost m => C.PaymentCredential -> Stream (Of (Either Types.ScriptResolutionFailure (C.TxIn, C.TxOut C.CtxUTxO C.ConwayEra))) m () streamUtxos a = S.mapM lookupUtxo - $ pagedStream (\p -> Client.getAddressUtxos' (Types.fromPaymentCredential a) p Client.Ascending) - -{-| Stream a list of results from a paged query --} -pagedStream :: Monad m => (Types.Paged -> m [a]) -> Stream (Of a) m () -pagedStream action = flip S.for S.each $ flip S.unfoldr 1 $ \pageNumber -> do - let paged = Client.Paged{Client.countPerPage = 100, Client.pageNumber = pageNumber} - action paged >>= \case - [] -> pure (Left ()) - xs -> pure (Right (xs, succ pageNumber)) + $ Types.pagedStream (\p -> Client.getAddressUtxos' (Types.fromPaymentCredential a) p Client.Ascending) {-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project' -} diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index 2105a075..84d797dd 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -1,55 +1,163 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-| blockfrost-based implementation of MonadBlockchain -} module Convex.Blockfrost.MonadBlockchain( BlockfrostState(..) ) where -import qualified Blockfrost.Client.Cardano.Ledger as Client -import Blockfrost.Client.Types (MonadBlockfrost (..)) -import Blockfrost.Types.Cardano.Genesis (Genesis) -import Cardano.Api (NetworkId) -import Cardano.Slotting.Time (SystemStart) -import Control.Lens (makeLensesFor, use, (?=)) -import Control.Monad.State (MonadState) -import qualified Convex.Blockfrost.Types as Types +import qualified Blockfrost.Client as Client +import Blockfrost.Client.Cardano.Transactions (submitTx) +import Blockfrost.Client.Types (MonadBlockfrost (..), + SortOrder (Ascending)) +import Blockfrost.Types.Cardano.Epochs (EpochInfo (..)) +import Blockfrost.Types.Cardano.Genesis (Genesis) +import qualified Blockfrost.Types.Cardano.Genesis as Genesis +import Blockfrost.Types.Shared.CBOR (CBORString (..)) +import Cardano.Api (ConwayEra, NetworkId, + Tx, TxId, TxIn (..), + serialiseToCBOR) +import Cardano.Api.NetworkId (fromNetworkMagic) +import Cardano.Api.Shelley (CtxUTxO, PoolId, TxOut, + UTxO) +import qualified Cardano.Api.Shelley as C +import Cardano.Slotting.Time (SystemStart) +import Control.Lens (Lens', at, + makeLensesFor, use, + (.=), (<>=), (?=)) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.State (MonadState) +import Convex.Blockfrost.Orphans () +import qualified Convex.Blockfrost.Types as Types +import Convex.Class (ValidationError) +import Convex.Utils (txnUtxos) +import Data.Bifunctor (Bifunctor (second)) +import qualified Data.ByteString.Lazy as BSL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Time.Clock (UTCTime, + getCurrentTime) +import qualified Data.Time.Clock.POSIX as Clock +import Data.Traversable (for) +import Ouroboros.Network.Magic (NetworkMagic (..)) +import qualified Streaming.Prelude as S --- send Tx --- utxoByTxIn +-- TODO -- protocol params -- stake addresses --- stake pools -- era history -- slot no + +-- DONE +-- utxoByTxIn +-- send Tx -- query network id +-- stake pools +-- system start data BlockfrostState = BlockfrostState - { bfsGenesis :: Maybe Genesis + { bfsGenesis :: Maybe Genesis + , bfsEndOfEpoch :: Maybe UTCTime + -- ^ End of current epoch + , bfsStakePools :: Maybe (Set PoolId) + -- ^ Stake pool IDs + , bfsTxInputs :: Map TxIn (TxOut CtxUTxO ConwayEra) + -- ^ Resolved tx inputs. We keep them around for a while because the + -- lookup on blockfrost is quite expensive (in terms HTTP requests + -- and CPU/memory usage) } makeLensesFor [ ("bfsGenesis", "genesis") + , ("bfsEndOfEpoch", "endOfEpoch") + , ("bfsStakePools", "stakePools") + , ("bfsTxInputs", "txInputs") ] ''BlockfrostState +{-| Check whether the next epoch has begun, and expire + all short-lived data if necessary. +-} +checkCurrentEpoch :: (MonadBlockfrost m, MonadState BlockfrostState m) => m () +checkCurrentEpoch = do + epochEnd <- use endOfEpoch + now <- liftIO getCurrentTime + case epochEnd of + Just t | t > now -> pure () -- we are still in the same epoch + _ -> do + -- set current epoch end + EpochInfo{_epochInfoEndTime} <- Client.getLatestEpoch + endOfEpoch .= Just (Clock.posixSecondsToUTCTime _epochInfoEndTime) + + -- reset everything + stakePools .= Nothing + + -- the (txIn -> txOut) mapping does not change at the epoch boundary. + -- So there is no risk of returning stale / incorrect data. + -- But we still clear the txInputs map here to avoid memory leaks. + txInputs .= mempty + emptyBlockfrostState :: BlockfrostState emptyBlockfrostState = BlockfrostState - { bfsGenesis = Nothing + { bfsGenesis = Nothing + , bfsEndOfEpoch = Nothing + , bfsStakePools = Nothing + , bfsTxInputs = Map.empty } -getSystemStart :: (MonadBlockfrost m, MonadState BlockfrostState m) => m SystemStart -getSystemStart = use genesis >>= \case - Just g -> pure (Types.systemStart g) +getGenesis :: (MonadBlockfrost m, MonadState BlockfrostState m) => m Genesis +getGenesis = getOrRetrieve genesis Client.getLedgerGenesis + +{-| Get a field from the state, using the action to load the value +if it is 'Nothing' +-} +getOrRetrieve :: MonadState s m => Lens' s (Maybe a) -> m a -> m a +getOrRetrieve lens action = use lens >>= \case + Just g -> pure g Nothing -> do - k <- Client.getLedgerGenesis - genesis ?= k - pure (Types.systemStart k) + k <- action + lens ?= k + pure k + +getSystemStart :: (MonadBlockfrost m, MonadState BlockfrostState m) => m SystemStart +getSystemStart = Types.systemStart <$> getGenesis getNetworkId :: (MonadBlockfrost m, MonadState BlockfrostState m) => m NetworkId -getNetworkId = undefined +getNetworkId = fromNetworkMagic . NetworkMagic . fromIntegral . Genesis._genesisNetworkMagic <$> getGenesis + +getStakePools :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (Set PoolId) +getStakePools = do + checkCurrentEpoch + getOrRetrieve stakePools $ + Set.fromList . fmap Types.poolId <$> S.toList_ (Types.pagedStream $ \page -> Client.listPools' page Ascending) --- Cardano.Api.NetworkId.fromNetworkMagic --- "network_magic": 764824073 (mainnet) \ No newline at end of file +{-| Send a transaction to the network using blockfrost's API +-} +sendTxBlockfrost :: MonadBlockfrost m => Tx ConwayEra -> m (Either (ValidationError ConwayEra) TxId) +sendTxBlockfrost = + fmap (Right . Types.toTxHash) . submitTx . CBORString . BSL.fromStrict . serialiseToCBOR + +{-| Get a single 'TxIn'. If it is not in the cache, download the entire transaction + and add all of its UTxOs to the cache. +-} +resolveTxIn :: (MonadBlockfrost m, MonadState BlockfrostState m) => TxIn -> m (TxOut CtxUTxO ConwayEra) +resolveTxIn txI@(TxIn txId (C.TxIx txIx)) = getOrRetrieve (txInputs . at txI) $ do + utxos <- runExceptT (Client.getTxCBOR (Types.fromTxHash txId) >>= Types.decodeTransactionCBOR) + -- FIXME: Error handling + >>= either (error . show) (pure . fmap (second C.toCtxUTxOTxOut) . txnUtxos) + txInputs <>= Map.fromList utxos + pure $ snd $ utxos !! fromIntegral txIx + +{-| Resolve the given tx inputs +-} +getUtxoByTxIn :: (MonadBlockfrost m, MonadState BlockfrostState m) => Set TxIn -> m (UTxO ConwayEra) +getUtxoByTxIn txIns = fmap (C.UTxO . Map.fromList) $ for (Set.toList txIns) $ \txIn -> + (txIn,) <$> resolveTxIn txIn diff --git a/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs b/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs new file mode 100644 index 00000000..38ca924b --- /dev/null +++ b/src/blockfrost/lib/Convex/Blockfrost/Orphans.hs @@ -0,0 +1,16 @@ + + +{-# OPTIONS_GHC -Wno-orphans #-} +{-| Missing instances for BlockfrostClientT +-} +module Convex.Blockfrost.Orphans( + +) where + +import Blockfrost.Client.Types (MonadBlockfrost (..)) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.Trans.Class (MonadTrans (..)) + +instance MonadBlockfrost m => MonadBlockfrost (ExceptT e 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 be04bfec..b239deaa 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -12,6 +12,7 @@ module Convex.Blockfrost.Types( toQuantity, toPolicyId, toTxHash, + fromTxHash, toAssetId, toAddress, toStakeAddress, @@ -26,27 +27,35 @@ module Convex.Blockfrost.Types( resolveScript, -- * CBOR toCBORString, + decodeTransactionCBOR, -- * Payment credential fromPaymentCredential, -- * Genesis related - systemStart + systemStart, + -- * Misc. + poolId, + -- * API queries + pagedStream ) where +import Blockfrost.Client (PoolId (..)) +import qualified Blockfrost.Client as Client import qualified Blockfrost.Client.Cardano.Scripts as Client import Blockfrost.Client.Types (MonadBlockfrost) +import qualified Blockfrost.Client.Types as Types import Blockfrost.Types.Cardano.Addresses (AddressUtxo (..)) +import Blockfrost.Types.Cardano.Genesis (Genesis (..)) import Blockfrost.Types.Cardano.Scripts (InlineDatum (..), Script (..), ScriptCBOR (..), ScriptDatumCBOR (..), ScriptType (..)) -import Blockfrost.Types.Cardano.Transactions (UtxoOutput (..)) +import Blockfrost.Types.Cardano.Transactions (TransactionCBOR (..), + UtxoOutput (..)) import Blockfrost.Types.Shared.Ada (Lovelaces) import Blockfrost.Types.Shared.Address (Address (..)) import Blockfrost.Types.Shared.Amount (Amount (..)) import Blockfrost.Types.Shared.CBOR (CBORString (..)) -import Cardano.Slotting.Time (SystemStart(..)) -import Blockfrost.Types.Cardano.Genesis (Genesis(..)) import Blockfrost.Types.Shared.DatumHash (DatumHash (..)) import Blockfrost.Types.Shared.PolicyId (PolicyId (..)) import Blockfrost.Types.Shared.Quantity (Quantity (..)) @@ -55,13 +64,13 @@ import Blockfrost.Types.Shared.TxHash (TxHash (..)) import Cardano.Api (HasTypeProxy (..)) import qualified Cardano.Api.Ledger as C.Ledger import Cardano.Api.SerialiseBech32 (SerialiseAsBech32 (..)) -import Data.Time.Clock.POSIX qualified as Clock import Cardano.Api.SerialiseUsing (UsingRawBytesHex (..)) import Cardano.Api.Shelley (Lovelace) import qualified Cardano.Api.Shelley as C import Cardano.Binary (DecoderError) import Cardano.Ledger.Binary.Encoding (EncCBOR) import qualified Cardano.Ledger.Binary.Version as Version +import Cardano.Slotting.Time (SystemStart (..)) import Control.Applicative (Alternative (..)) import Control.Lens (_4, (&), (.~), (<&>)) import Control.Monad.Except (MonadError (..), @@ -77,8 +86,11 @@ import Data.Proxy (Proxy (..)) import Data.String (IsString (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Time.Clock.POSIX as Clock import qualified GHC.IsList as L import qualified Money +import qualified Streaming.Prelude as S +import Streaming.Prelude (Of, Stream) toLovelace :: Lovelaces -> Lovelace toLovelace = C.Ledger.Coin . toInteger @@ -92,6 +104,9 @@ toPolicyId = textToIsString toTxHash :: TxHash -> C.TxId toTxHash = textToIsString +fromTxHash :: C.TxId -> TxHash +fromTxHash = TxHash . C.serialiseToRawBytesHexText + textToIsString :: (Coercible a Text.Text, IsString b) => a -> b textToIsString = fromString . Text.unpack . coerce @@ -100,6 +115,9 @@ hexTextToByteString t = let UsingRawBytesHex x = fromString (Text.unpack t) in x +poolId :: PoolId -> C.PoolId +poolId = textToIsString + toAssetId :: Amount -> (C.AssetId, C.Quantity) toAssetId = \case AdaAmount lvl -> (C.AdaAssetId, C.lovelaceToQuantity $ toLovelace lvl) @@ -180,13 +198,18 @@ data TxOutUnresolvedScript era = -} data ScriptResolutionFailure = ScriptNotFound ScriptHash - | Base16DecodeError ScriptType ScriptHash String - | CBORError ScriptType ScriptHash DecoderError + | ScriptDecodingError ScriptType ScriptHash DecodingError + deriving stock (Eq, Show) + +data DecodingError + = Base16DecodeError String + | CBORError DecoderError + deriving stock (Eq, Show) decodeScriptCbor :: forall lang m. (MonadError ScriptResolutionFailure m, C.IsScriptLanguage lang) => ScriptType -> ScriptHash -> Text.Text -> m (C.Script lang) decodeScriptCbor tp hsh text = - either (throwError . Base16DecodeError tp hsh) pure (Base16.decode $ Text.Encoding.encodeUtf8 text) - >>= either (throwError . CBORError tp hsh) pure . C.deserialiseFromCBOR (C.proxyToAsType $ Proxy @(C.Script lang)) + either (throwError . ScriptDecodingError tp hsh . Base16DecodeError) pure (Base16.decode $ Text.Encoding.encodeUtf8 text) + >>= either (throwError . ScriptDecodingError tp hsh . CBORError) pure . C.deserialiseFromCBOR (C.proxyToAsType $ Proxy @(C.Script lang)) {-| Load this output's reference script from blockfrost and return the full output -} @@ -259,8 +282,24 @@ addressUtxo AddressUtxo{_addressUtxoAddress, _addressUtxoAmount, _addressUtxoDat toCBORString :: EncCBOR v => v -> CBORString toCBORString = CBORString . BSL.fromStrict . C.Ledger.serialize' Version.shelleyProtVer +{-| Decode a full transaction from a CBOR hex string +-} +decodeTransactionCBOR :: MonadError DecodingError m => TransactionCBOR -> m (C.Tx C.ConwayEra) +decodeTransactionCBOR TransactionCBOR{_transactionCBORCbor} = + either (throwError . Base16DecodeError) pure (Base16.decode $ Text.Encoding.encodeUtf8 _transactionCBORCbor) + >>= either (throwError . CBORError) pure . C.deserialiseFromCBOR (C.proxyToAsType $ Proxy @(C.Tx C.ConwayEra)) + {-| The 'SystemStart' value -} systemStart :: Genesis -> SystemStart systemStart = - SystemStart . Clock.posixSecondsToUTCTime . _genesisSystemStart \ No newline at end of file + SystemStart . Clock.posixSecondsToUTCTime . _genesisSystemStart + +{-| Stream a list of results from a paged query +-} +pagedStream :: Monad m => (Types.Paged -> m [a]) -> Stream (Of a) m () +pagedStream action = flip S.for S.each $ flip S.unfoldr 1 $ \pageNumber -> do + let paged = Client.Paged{Client.countPerPage = 100, Client.pageNumber = pageNumber} + action paged >>= \case + [] -> pure (Left ()) + xs -> pure (Right (xs, succ pageNumber)) From 9c01114057aa0e8c6b173f9b28c8a1d8a3df17a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Wed, 4 Dec 2024 12:29:16 +0100 Subject: [PATCH 3/8] Era history --- src/blockfrost/convex-blockfrost.cabal | 5 +- .../lib/Convex/Blockfrost/MonadBlockchain.hs | 114 ++++++++----- src/blockfrost/lib/Convex/Blockfrost/Types.hs | 153 ++++++++++++------ 3 files changed, 176 insertions(+), 96 deletions(-) diff --git a/src/blockfrost/convex-blockfrost.cabal b/src/blockfrost/convex-blockfrost.cabal index 7df598ef..e9a45b62 100644 --- a/src/blockfrost/convex-blockfrost.cabal +++ b/src/blockfrost/convex-blockfrost.cabal @@ -54,7 +54,10 @@ library streaming, time, lens, - ouroboros-network-api + ouroboros-network-api, + ouroboros-consensus, + ouroboros-consensus-cardano, + sop-extras test-suite convex-blockfrost-test import: lang diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index 84d797dd..8d138bec 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -1,52 +1,62 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-| blockfrost-based implementation of MonadBlockchain -} module Convex.Blockfrost.MonadBlockchain( BlockfrostState(..) ) where -import qualified Blockfrost.Client as Client -import Blockfrost.Client.Cardano.Transactions (submitTx) -import Blockfrost.Client.Types (MonadBlockfrost (..), - SortOrder (Ascending)) -import Blockfrost.Types.Cardano.Epochs (EpochInfo (..)) -import Blockfrost.Types.Cardano.Genesis (Genesis) -import qualified Blockfrost.Types.Cardano.Genesis as Genesis -import Blockfrost.Types.Shared.CBOR (CBORString (..)) -import Cardano.Api (ConwayEra, NetworkId, - Tx, TxId, TxIn (..), - serialiseToCBOR) -import Cardano.Api.NetworkId (fromNetworkMagic) -import Cardano.Api.Shelley (CtxUTxO, PoolId, TxOut, - UTxO) -import qualified Cardano.Api.Shelley as C -import Cardano.Slotting.Time (SystemStart) -import Control.Lens (Lens', at, - makeLensesFor, use, - (.=), (<>=), (?=)) -import Control.Monad.Except (runExceptT) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.State (MonadState) -import Convex.Blockfrost.Orphans () -import qualified Convex.Blockfrost.Types as Types -import Convex.Class (ValidationError) -import Convex.Utils (txnUtxos) -import Data.Bifunctor (Bifunctor (second)) -import qualified Data.ByteString.Lazy as BSL -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Time.Clock (UTCTime, - getCurrentTime) -import qualified Data.Time.Clock.POSIX as Clock -import Data.Traversable (for) -import Ouroboros.Network.Magic (NetworkMagic (..)) -import qualified Streaming.Prelude as S +import qualified Blockfrost.Client as Client +import Blockfrost.Client.Cardano.Transactions (submitTx) +import Blockfrost.Client.Types (MonadBlockfrost (..), + SortOrder (Ascending)) +import Blockfrost.Types.Cardano.Epochs (EpochInfo (..)) +import Blockfrost.Types.Cardano.Genesis (Genesis) +import qualified Blockfrost.Types.Cardano.Genesis as Genesis +import Blockfrost.Types.Shared.CBOR (CBORString (..)) +import Cardano.Api (ConwayEra, + NetworkId, Tx, + TxId, TxIn (..), + serialiseToCBOR) +import Cardano.Api.NetworkId (fromNetworkMagic) +import Cardano.Api.Shelley (CtxUTxO, PoolId, + TxOut, UTxO) +import qualified Cardano.Api.Shelley as C +import Cardano.Slotting.Time (SystemStart) +import Control.Lens (Lens', at, + makeLensesFor, + use, (.=), (<>=), + (?=)) +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.State (MonadState) +import Convex.Blockfrost.Orphans () +import qualified Convex.Blockfrost.Types as Types +import Convex.Class (ValidationError) +import Convex.Utils (txnUtxos) +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.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) +import qualified Data.Time.Clock.POSIX as Clock +import Data.Traversable (for) +import Ouroboros.Consensus.Cardano.Block (CardanoEras, + StandardCrypto) +import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry +import qualified Ouroboros.Consensus.HardFork.History.Summary as Summary +import Ouroboros.Network.Magic (NetworkMagic (..)) +import qualified Streaming.Prelude as S -- TODO -- protocol params @@ -72,6 +82,9 @@ data BlockfrostState = -- ^ Resolved tx inputs. We keep them around for a while because the -- lookup on blockfrost is quite expensive (in terms HTTP requests -- and CPU/memory usage) + + , bfsEraHistory :: Maybe C.EraHistory + -- ^ Era history } makeLensesFor @@ -79,6 +92,7 @@ makeLensesFor , ("bfsEndOfEpoch", "endOfEpoch") , ("bfsStakePools", "stakePools") , ("bfsTxInputs", "txInputs") + , ("bfsEraHistory", "eraHistory") ] ''BlockfrostState @@ -111,6 +125,7 @@ emptyBlockfrostState = , bfsEndOfEpoch = Nothing , bfsStakePools = Nothing , bfsTxInputs = Map.empty + , bfsEraHistory = Nothing } getGenesis :: (MonadBlockfrost m, MonadState BlockfrostState m) => m Genesis @@ -161,3 +176,16 @@ resolveTxIn txI@(TxIn txId (C.TxIx txIx)) = getOrRetrieve (txInputs . at txI) $ getUtxoByTxIn :: (MonadBlockfrost m, MonadState BlockfrostState m) => Set TxIn -> m (UTxO ConwayEra) getUtxoByTxIn txIns = fmap (C.UTxO . Map.fromList) $ for (Set.toList txIns) $ \txIn -> (txIn,) <$> resolveTxIn txIn + +{-| Get the 'EraHistory' for slot time computations +-} +getEraHistory :: (MonadBlockfrost m, MonadState BlockfrostState m) => m C.EraHistory +getEraHistory = getOrRetrieve eraHistory $ do + networkEras <- Client.getNetworkEras + let summaries :: [Summary.EraSummary] = fmap Types.eraSummary networkEras + pure + $ C.EraHistory + $ Qry.mkInterpreter + $ Summary.Summary + $ fromJust (error "getEraHistory: Unexpected number of entries") + $ NonEmpty.nonEmptyFromList @(CardanoEras StandardCrypto) summaries diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index b239deaa..22716456 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -34,63 +34,81 @@ module Convex.Blockfrost.Types( systemStart, -- * Misc. poolId, + eraSummary, -- * API queries pagedStream ) where -import Blockfrost.Client (PoolId (..)) -import qualified Blockfrost.Client as Client -import qualified Blockfrost.Client.Cardano.Scripts as Client -import Blockfrost.Client.Types (MonadBlockfrost) -import qualified Blockfrost.Client.Types as Types -import Blockfrost.Types.Cardano.Addresses (AddressUtxo (..)) -import Blockfrost.Types.Cardano.Genesis (Genesis (..)) -import Blockfrost.Types.Cardano.Scripts (InlineDatum (..), - Script (..), - ScriptCBOR (..), - ScriptDatumCBOR (..), - ScriptType (..)) -import Blockfrost.Types.Cardano.Transactions (TransactionCBOR (..), - UtxoOutput (..)) -import Blockfrost.Types.Shared.Ada (Lovelaces) -import Blockfrost.Types.Shared.Address (Address (..)) -import Blockfrost.Types.Shared.Amount (Amount (..)) -import Blockfrost.Types.Shared.CBOR (CBORString (..)) -import Blockfrost.Types.Shared.DatumHash (DatumHash (..)) -import Blockfrost.Types.Shared.PolicyId (PolicyId (..)) -import Blockfrost.Types.Shared.Quantity (Quantity (..)) -import Blockfrost.Types.Shared.ScriptHash (ScriptHash (..)) -import Blockfrost.Types.Shared.TxHash (TxHash (..)) -import Cardano.Api (HasTypeProxy (..)) -import qualified Cardano.Api.Ledger as C.Ledger -import Cardano.Api.SerialiseBech32 (SerialiseAsBech32 (..)) -import Cardano.Api.SerialiseUsing (UsingRawBytesHex (..)) -import Cardano.Api.Shelley (Lovelace) -import qualified Cardano.Api.Shelley as C -import Cardano.Binary (DecoderError) -import Cardano.Ledger.Binary.Encoding (EncCBOR) -import qualified Cardano.Ledger.Binary.Version as Version -import Cardano.Slotting.Time (SystemStart (..)) -import Control.Applicative (Alternative (..)) -import Control.Lens (_4, (&), (.~), (<&>)) -import Control.Monad.Except (MonadError (..), - runExceptT, throwError) -import Control.Monad.Trans.Class (lift) -import qualified Convex.CardanoApi.Lenses as L -import Convex.Utils (inBabbage) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Lazy as BSL -import Data.Coerce (Coercible, coerce) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy (..)) -import Data.String (IsString (..)) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text.Encoding -import qualified Data.Time.Clock.POSIX as Clock -import qualified GHC.IsList as L +import Blockfrost.Client (Epoch (..), + EpochLength (..), + NetworkEraBound (..), + NetworkEraParameters (..), + NetworkEraSummary (..), + PoolId (..), + Slot (..)) +import qualified Blockfrost.Client as Client +import Blockfrost.Client.Types (MonadBlockfrost) +import qualified Blockfrost.Client.Types as Types +import Blockfrost.Types.Cardano.Addresses (AddressUtxo (..)) +import Blockfrost.Types.Cardano.Genesis (Genesis (..)) +import Blockfrost.Types.Cardano.Scripts (InlineDatum (..), + Script (..), + ScriptCBOR (..), + ScriptDatumCBOR (..), + ScriptType (..)) +import Blockfrost.Types.Cardano.Transactions (TransactionCBOR (..), + UtxoOutput (..)) +import Blockfrost.Types.Shared.Ada (Lovelaces) +import Blockfrost.Types.Shared.Address (Address (..)) +import Blockfrost.Types.Shared.Amount (Amount (..)) +import Blockfrost.Types.Shared.CBOR (CBORString (..)) +import Blockfrost.Types.Shared.DatumHash (DatumHash (..)) +import Blockfrost.Types.Shared.PolicyId (PolicyId (..)) +import Blockfrost.Types.Shared.Quantity (Quantity (..)) +import Blockfrost.Types.Shared.ScriptHash (ScriptHash (..)) +import Blockfrost.Types.Shared.TxHash (TxHash (..)) +import Cardano.Api (HasTypeProxy (..)) +import qualified Cardano.Api.Ledger as C.Ledger +import Cardano.Api.SerialiseBech32 (SerialiseAsBech32 (..)) +import Cardano.Api.SerialiseUsing (UsingRawBytesHex (..)) +import Cardano.Api.Shelley (Lovelace) +import qualified Cardano.Api.Shelley as C +import Cardano.Binary (DecoderError) +import Cardano.Ledger.Binary.Encoding (EncCBOR) +import qualified Cardano.Ledger.Binary.Version as Version +import Cardano.Slotting.Slot (EpochSize (..)) +import Cardano.Slotting.Time (RelativeTime (..), + SystemStart (..), + mkSlotLength) +import Control.Applicative (Alternative (..)) +import Control.Lens (_4, (&), (.~), + (<&>)) +import Control.Monad.Except (MonadError (..), + runExceptT, + throwError) +import Control.Monad.Trans.Class (lift) +import qualified Convex.CardanoApi.Lenses as L +import Convex.Utils (inBabbage) +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (Coercible, + coerce) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.String (IsString (..)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text.Encoding +import qualified Data.Time.Clock.POSIX as Clock +import qualified GHC.IsList as L import qualified Money -import qualified Streaming.Prelude as S -import Streaming.Prelude (Of, Stream) +import qualified Ouroboros.Consensus.Block.Abstract as Ouroboros +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..), + SafeZone (StandardSafeZone)) +import Ouroboros.Consensus.HardFork.History.Summary (Bound (..), + EraEnd (..), + EraSummary (..)) +import qualified Streaming.Prelude as S +import Streaming.Prelude (Of, Stream) toLovelace :: Lovelaces -> Lovelace toLovelace = C.Ledger.Coin . toInteger @@ -303,3 +321,34 @@ pagedStream action = flip S.for S.each $ flip S.unfoldr 1 $ \pageNumber -> do action paged >>= \case [] -> pure (Left ()) xs -> pure (Right (xs, succ pageNumber)) + +slot :: Slot -> C.SlotNo +slot (Slot n) = C.SlotNo (fromInteger n) + +epoch :: Epoch -> C.EpochNo +epoch (Epoch e) = C.EpochNo (fromInteger e) + +epochSize :: EpochLength -> EpochSize +epochSize = coerce + +eraSummary :: NetworkEraSummary -> EraSummary +eraSummary NetworkEraSummary{_networkEraStart, _networkEraEnd, _networkEraParameters} = + let eraEnd = + let NetworkEraBound{_boundEpoch, _boundSlot, _boundTime} = _networkEraEnd + in EraEnd Bound{boundTime = RelativeTime _boundTime, boundSlot = slot _boundSlot, boundEpoch = epoch _boundEpoch} + eraStart = + let NetworkEraBound{_boundEpoch, _boundSlot, _boundTime} = _networkEraStart + in Bound{boundTime = RelativeTime _boundTime, boundSlot = slot _boundSlot, boundEpoch = epoch _boundEpoch} + eraParams = + let NetworkEraParameters{_parametersEpochLength, _parametersSlotLength, _parametersSafeZone} = _networkEraParameters + in EraParams + { eraEpochSize = epochSize _parametersEpochLength + , eraSlotLength = mkSlotLength _parametersSlotLength + , eraSafeZone = StandardSafeZone _parametersSafeZone + , eraGenesisWin = Ouroboros.GenesisWindow (2 * 2160) -- 2 * max-rollbacks + } + in EraSummary + { eraEnd + , eraStart + , eraParams + } From 8e080ae145186d2df21da669f44a5539e19bf9dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Wed, 4 Dec 2024 14:28:42 +0100 Subject: [PATCH 4/8] getSlotNo --- .../lib/Convex/Blockfrost/MonadBlockchain.hs | 23 +++++++++++++++---- src/blockfrost/lib/Convex/Blockfrost/Types.hs | 1 + 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index 8d138bec..c187e85a 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -10,6 +10,7 @@ module Convex.Blockfrost.MonadBlockchain( BlockfrostState(..) ) where +import Blockfrost.Client (Block (..)) import qualified Blockfrost.Client as Client import Blockfrost.Client.Cardano.Transactions (submitTx) import Blockfrost.Client.Types (MonadBlockfrost (..), @@ -26,7 +27,8 @@ import Cardano.Api.NetworkId (fromNetworkMagic) import Cardano.Api.Shelley (CtxUTxO, PoolId, TxOut, UTxO) import qualified Cardano.Api.Shelley as C -import Cardano.Slotting.Time (SystemStart) +import Cardano.Slotting.Time (SlotLength, + SystemStart) import Control.Lens (Lens', at, makeLensesFor, use, (.=), (<>=), @@ -37,7 +39,8 @@ import Control.Monad.State (MonadState) import Convex.Blockfrost.Orphans () import qualified Convex.Blockfrost.Types as Types import Convex.Class (ValidationError) -import Convex.Utils (txnUtxos) +import Convex.Utils (slotToUtcTime, + txnUtxos) import Data.Bifunctor (Bifunctor (second)) import qualified Data.ByteString.Lazy as BSL import Data.Map (Map) @@ -61,10 +64,10 @@ import qualified Streaming.Prelude as S -- TODO -- protocol params -- stake addresses --- era history --- slot no -- DONE +-- slot no +-- era history -- utxoByTxIn -- send Tx -- query network id @@ -189,3 +192,15 @@ getEraHistory = getOrRetrieve eraHistory $ do $ Summary.Summary $ fromJust (error "getEraHistory: Unexpected number of entries") $ NonEmpty.nonEmptyFromList @(CardanoEras StandardCrypto) summaries + +{-| Get the current slot number, slot length and UTC time of the start +of the current slot. +-} +getSlotNo :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (C.SlotNo, SlotLength, UTCTime) +getSlotNo = do + (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) + l = either (error . (<>) "getSlotNo: slotToSlotLength failed " . show) id (Qry.interpretQuery interpreter $ Qry.slotToSlotLength currentSlot) + pure (currentSlot, l, utctime) diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index 22716456..c76e50e3 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -35,6 +35,7 @@ module Convex.Blockfrost.Types( -- * Misc. poolId, eraSummary, + slot, -- * API queries pagedStream ) where From be9f46a3c6735d37e2157bae357a5ba2f4d91edc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Thu, 5 Dec 2024 10:40:36 +0100 Subject: [PATCH 5/8] Add protocol parameters --- src/blockfrost/convex-blockfrost.cabal | 4 + .../lib/Convex/Blockfrost/MonadBlockchain.hs | 31 +++- src/blockfrost/lib/Convex/Blockfrost/Types.hs | 145 +++++++++++++++++- 3 files changed, 170 insertions(+), 10 deletions(-) diff --git a/src/blockfrost/convex-blockfrost.cabal b/src/blockfrost/convex-blockfrost.cabal index e9a45b62..40aa15ac 100644 --- a/src/blockfrost/convex-blockfrost.cabal +++ b/src/blockfrost/convex-blockfrost.cabal @@ -44,6 +44,10 @@ library cardano-api, cardano-api:internal, cardano-ledger-binary, + cardano-ledger-alonzo, + cardano-ledger-babbage, + cardano-ledger-core, + cardano-ledger-conway, cardano-slotting, convex-base, convex-optics, diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index c187e85a..eee64885 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -24,8 +24,10 @@ import Cardano.Api (ConwayEra, TxId, TxIn (..), serialiseToCBOR) import Cardano.Api.NetworkId (fromNetworkMagic) -import Cardano.Api.Shelley (CtxUTxO, PoolId, - TxOut, UTxO) +import Cardano.Api.Shelley (CtxUTxO, + LedgerProtocolParameters (..), + PoolId, TxOut, + UTxO) import qualified Cardano.Api.Shelley as C import Cardano.Slotting.Time (SlotLength, SystemStart) @@ -62,10 +64,10 @@ import Ouroboros.Network.Magic (NetworkMagic (..) import qualified Streaming.Prelude as S -- TODO --- protocol params -- stake addresses -- DONE +-- protocol params -- slot no -- era history -- utxoByTxIn @@ -76,17 +78,19 @@ import qualified Streaming.Prelude as S data BlockfrostState = BlockfrostState - { bfsGenesis :: Maybe Genesis - , bfsEndOfEpoch :: Maybe UTCTime + { bfsGenesis :: Maybe Genesis + , bfsEndOfEpoch :: Maybe UTCTime -- ^ End of current epoch - , bfsStakePools :: Maybe (Set PoolId) + , bfsStakePools :: Maybe (Set PoolId) -- ^ Stake pool IDs - , bfsTxInputs :: Map TxIn (TxOut CtxUTxO ConwayEra) + , bfsTxInputs :: Map TxIn (TxOut CtxUTxO ConwayEra) -- ^ Resolved tx inputs. We keep them around for a while because the -- lookup on blockfrost is quite expensive (in terms HTTP requests -- and CPU/memory usage) - , bfsEraHistory :: Maybe C.EraHistory + , bfsProtocolParams :: Maybe (LedgerProtocolParameters ConwayEra) + + , bfsEraHistory :: Maybe C.EraHistory -- ^ Era history } @@ -95,6 +99,7 @@ makeLensesFor , ("bfsEndOfEpoch", "endOfEpoch") , ("bfsStakePools", "stakePools") , ("bfsTxInputs", "txInputs") + , ("bfsProtocolParams", "protocolParams") , ("bfsEraHistory", "eraHistory") ] ''BlockfrostState @@ -115,6 +120,7 @@ checkCurrentEpoch = do -- reset everything stakePools .= Nothing + protocolParams .= Nothing -- the (txIn -> txOut) mapping does not change at the epoch boundary. -- So there is no risk of returning stale / incorrect data. @@ -128,6 +134,7 @@ emptyBlockfrostState = , bfsEndOfEpoch = Nothing , bfsStakePools = Nothing , bfsTxInputs = Map.empty + , bfsProtocolParams = Nothing , bfsEraHistory = Nothing } @@ -204,3 +211,11 @@ getSlotNo = do 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) + +{-| Get the current protocol parameters +-} +getProtocolParams :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (LedgerProtocolParameters ConwayEra) +getProtocolParams = do + checkCurrentEpoch + getOrRetrieve protocolParams $ + LedgerProtocolParameters . Types.protocolParametersConway <$> Client.getLatestEpochProtocolParams diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index c76e50e3..e7eadd35 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-| Conversion between blockfrost and @cardano-api@ types @@ -25,6 +26,8 @@ module Convex.Blockfrost.Types( addressUtxoTxIn, ScriptResolutionFailure(..), resolveScript, + -- * Protocol parameters + protocolParametersConway, -- * CBOR toCBORString, decodeTransactionCBOR, @@ -40,12 +43,14 @@ module Convex.Blockfrost.Types( pagedStream ) where -import Blockfrost.Client (Epoch (..), +import Blockfrost.Client (CostModelsRaw (..), + Epoch (..), EpochLength (..), NetworkEraBound (..), NetworkEraParameters (..), NetworkEraSummary (..), PoolId (..), + ProtocolParams (..), Slot (..)) import qualified Blockfrost.Client as Client import Blockfrost.Client.Types (MonadBlockfrost) @@ -70,13 +75,23 @@ import Blockfrost.Types.Shared.ScriptHash (ScriptHash (..) import Blockfrost.Types.Shared.TxHash (TxHash (..)) import Cardano.Api (HasTypeProxy (..)) import qualified Cardano.Api.Ledger as C.Ledger +import qualified Cardano.Api.Ledger as L import Cardano.Api.SerialiseBech32 (SerialiseAsBech32 (..)) import Cardano.Api.SerialiseUsing (UsingRawBytesHex (..)) import Cardano.Api.Shelley (Lovelace) import qualified Cardano.Api.Shelley as C import Cardano.Binary (DecoderError) +import qualified Cardano.Ledger.Alonzo.PParams as L +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 qualified Cardano.Ledger.Plutus.CostModels as CostModels +import qualified Cardano.Ledger.Plutus.Language as Plutus.Language import Cardano.Slotting.Slot (EpochSize (..)) import Cardano.Slotting.Time (RelativeTime (..), SystemStart (..), @@ -90,17 +105,22 @@ 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, coerce) -import Data.Maybe (fromMaybe) +import Data.Int (Int64) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, + mapMaybe) import Data.Proxy (Proxy (..)) import Data.String (IsString (..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text.Encoding import qualified Data.Time.Clock.POSIX as Clock import qualified GHC.IsList as L +import GHC.Num.Natural (Natural) import qualified Money import qualified Ouroboros.Consensus.Block.Abstract as Ouroboros import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..), @@ -108,6 +128,8 @@ import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..), 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) @@ -134,6 +156,9 @@ hexTextToByteString t = let UsingRawBytesHex x = fromString (Text.unpack t) in x +quantity :: Quantity -> Natural +quantity (Quantity n) = fromInteger n + poolId :: PoolId -> C.PoolId poolId = textToIsString @@ -353,3 +378,119 @@ eraSummary NetworkEraSummary{_networkEraStart, _networkEraEnd, _networkEraParame , eraStart , eraParams } + +costModels :: CostModelsRaw -> L.CostModels +costModels = + let unsafeMkCostModel :: Plutus.Language.Language -> [Int64] -> CostModels.CostModel + unsafeMkCostModel lang = either (error . show) id . CostModels.mkCostModel lang + mkModel (scriptType, cost) = do + l <- plutusLanguage scriptType + pure (l, unsafeMkCostModel l (fromInteger <$> cost)) + in + CostModels.mkCostModels + . Map.fromList + . mapMaybe mkModel + . Map.toList + . unCostModelsRaw + +plutusLanguage :: ScriptType -> Maybe Plutus.Language.Language +plutusLanguage = \case + PlutusV1 -> Just Plutus.Language.PlutusV1 + PlutusV2 -> Just Plutus.Language.PlutusV2 + PlutusV3 -> Just Plutus.Language.PlutusV3 + Timelock -> Nothing + +{- Note [Protocol Parameter Conversion] + +The protocol parameters type varies from era to era. + +Blockfrost captures all possible protocol parameters in a single 'ProtocolParams' +type. In the Conway era, a number of fields were added to the protocol +parameters that appear as optional ('Maybe') in the 'ProtocolParams' but are +in fact mandatory. Some examples are "min ref script cost per byte" and +the drep / pool voting related parameters. + +When converting from 'ProtocolParams' to conway-era params, if one of those +mandatory fields is missing, we use the default from the conway genesis file +on mainnet. + +-} + +{-| Convert the 'ProtocolParams' to conway-era ledger params. +See note [Protocol Parameter Conversion] +-} +protocolParametersConway :: ProtocolParams -> PParams StandardConway +protocolParametersConway pp = + let votingThresholdFromRational = C.unsafeBoundedRational @BaseTypes.UnitInterval . fromMaybe 0.51 in + L.PParams $ + L.emptyPParamsIdentity @StandardConway + & L.hkdMinFeeAL .~ L.Coin (_protocolParamsMinFeeA pp) + & L.hkdMinFeeBL .~ L.Coin (_protocolParamsMinFeeB pp) + & L.hkdMaxBBSizeL .~ fromInteger (_protocolParamsMaxBlockSize pp) + & L.hkdMaxTxSizeL .~ fromInteger (_protocolParamsMaxTxSize pp) + & L.hkdMaxBHSizeL .~ fromInteger (_protocolParamsMaxBlockHeaderSize pp) + & L.hkdKeyDepositL .~ toLovelace (_protocolParamsKeyDeposit pp) + & L.hkdPoolDepositL .~ toLovelace (_protocolParamsKeyDeposit pp) + & L.hkdEMaxL .~ L.EpochInterval (fromInteger (_protocolParamsEMax pp)) + & L.hkdNOptL .~ fromInteger (_protocolParamsNOpt pp) + & L.hkdA0L .~ C.unsafeBoundedRational (_protocolParamsA0 pp) -- TODO: Is unsafeBoundedRational ok to use here? + & L.hkdRhoL .~ C.unsafeBoundedRational (_protocolParamsRho pp) + & L.hkdTauL .~ C.unsafeBoundedRational (_protocolParamsTau pp) + -- & L.hkdDL .~ _ (_protocolParamsDecentralisationParam pp) + -- & L.hkdExtraEntropyL .~ + -- maybe BaseTypes.NeutralNonce (BaseTypes.Nonce . _) (_protocolParamsExtraEntropy pp) + -- & L.hkdExtraEntropyL .~ _ (_protocolParamsExtraEntropy pp) + -- & L.ppProtocolVersionL .~ + -- L.ProtVer + -- { L.pvMajor = _ (_protocolParamsProtocolMajorVer pp) + -- , L.pvMinor = _ (_protocolParamsProtocolMinorVer pp) + -- } + & L.hkdMinPoolCostL .~ toLovelace (_protocolParamsMinPoolCost pp) + & L.hkdCostModelsL .~ costModels (_protocolParamsCostModelsRaw pp) + & L.hkdPricesL .~ L.Prices + { L.prMem = C.unsafeBoundedRational (_protocolParamsPriceMem pp) + , L.prSteps = C.unsafeBoundedRational (_protocolParamsPriceStep pp) + } + & L.hkdMaxTxExUnitsL .~ L.ExUnits + { L.exUnitsSteps = quantity (_protocolParamsMaxTxExSteps pp) + , L.exUnitsMem = quantity (_protocolParamsMaxTxExMem pp) + } + & L.hkdMaxBlockExUnitsL .~ L.ExUnits + { L.exUnitsSteps = quantity (_protocolParamsMaxBlockExSteps pp) + , L.exUnitsMem = quantity (_protocolParamsMaxBlockExMem pp) + } + & L.hkdMaxValSizeL .~ quantity (_protocolParamsMaxValSize pp) + & L.hkdCollateralPercentageL .~ fromInteger (_protocolParamsCollateralPercent pp) + & L.hkdMaxCollateralInputsL .~ fromInteger (_protocolParamsMaxCollateralInputs pp) + & L.hkdCoinsPerUTxOByteL .~ L.CoinPerByte (toLovelace (_protocolParamsCoinsPerUtxoSize pp)) + + -- Conway-specific values + -- see note [Protocol Parameter Conversion] + & L.hkdPoolVotingThresholdsL .~ + L.PoolVotingThresholds + { L.pvtMotionNoConfidence = votingThresholdFromRational (_protocolParamsPvtMotionNoConfidence pp) + , L.pvtCommitteeNormal = votingThresholdFromRational (_protocolParamsPvtCommitteeNormal pp) + , L.pvtCommitteeNoConfidence = votingThresholdFromRational (_protocolParamsPvtCommitteeNoConfidence pp) + , L.pvtHardForkInitiation = votingThresholdFromRational (_protocolParamsPvtHardForkInitiation pp) + , L.pvtPPSecurityGroup = votingThresholdFromRational (_protocolParamsPvtppSecurityGroup pp) + } + & L.hkdDRepVotingThresholdsL .~ + L.DRepVotingThresholds + { L.dvtMotionNoConfidence = votingThresholdFromRational (_protocolParamsDvtMotionNoConfidence pp) + , L.dvtCommitteeNormal = votingThresholdFromRational (_protocolParamsDvtCommitteeNormal pp) + , L.dvtCommitteeNoConfidence = votingThresholdFromRational (_protocolParamsDvtCommitteeNoConfidence pp) + , L.dvtUpdateToConstitution = votingThresholdFromRational (_protocolParamsDvtUpdateToConstitution pp) + , L.dvtHardForkInitiation = votingThresholdFromRational (_protocolParamsDvtHardForkInitiation pp) + , L.dvtPPNetworkGroup = votingThresholdFromRational (_protocolParamsDvtPPNetworkGroup pp) + , L.dvtPPEconomicGroup = votingThresholdFromRational (_protocolParamsDvtPPEconomicGroup pp) + , L.dvtPPTechnicalGroup = votingThresholdFromRational (_protocolParamsDvtPPTechnicalGroup pp) + , L.dvtPPGovGroup = votingThresholdFromRational (_protocolParamsDvtPPGovGroup pp) + , L.dvtTreasuryWithdrawal = votingThresholdFromRational (_protocolParamsDvtTreasuryWithdrawal pp) + } + & L.hkdCommitteeMinSizeL .~ maybe 7 quantity (_protocolParamsCommitteeMinSize pp) + & L.hkdCommitteeMaxTermLengthL .~ BaseTypes.EpochInterval (maybe 146 (fromIntegral . quantity) (_protocolParamsCommitteeMaxTermLength pp)) + & L.hkdGovActionLifetimeL .~ BaseTypes.EpochInterval (maybe 6 (fromIntegral . quantity) (_protocolParamsGovActionLifetime pp)) + & L.hkdGovActionDepositL .~ maybe 100_000_000_000 toLovelace (_protocolParamsGovActionDeposit pp) + & L.hkdDRepDepositL .~ maybe 500_000_000 toLovelace (_protocolParamsDrepDeposit pp) + & L.hkdDRepActivityL .~ BaseTypes.EpochInterval (maybe 20 (fromIntegral . quantity) (_protocolParamsDrepActivity pp)) + & L.hkdMinFeeRefScriptCostPerByteL .~ C.unsafeBoundedRational (fromMaybe 15 (_protocolParamsMinFeeRefScriptCostPerByte pp)) From e6a3638a65014ddc6869e7154e7b16871d83b109 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Thu, 5 Dec 2024 14:54:10 +0100 Subject: [PATCH 6/8] WIP stake information --- .../lib/Convex/Blockfrost/MonadBlockchain.hs | 20 ++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index eee64885..7a9a879a 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -10,7 +10,8 @@ module Convex.Blockfrost.MonadBlockchain( BlockfrostState(..) ) where -import Blockfrost.Client (Block (..)) +import Blockfrost.Client (AccountInfo (..), + Block (..)) import qualified Blockfrost.Client as Client import Blockfrost.Client.Cardano.Transactions (submitTx) import Blockfrost.Client.Types (MonadBlockfrost (..), @@ -26,8 +27,9 @@ import Cardano.Api (ConwayEra, import Cardano.Api.NetworkId (fromNetworkMagic) import Cardano.Api.Shelley (CtxUTxO, LedgerProtocolParameters (..), - PoolId, TxOut, - UTxO) + PoolId, + StakeCredential, + TxOut, UTxO) import qualified Cardano.Api.Shelley as C import Cardano.Slotting.Time (SlotLength, SystemStart) @@ -90,6 +92,8 @@ data BlockfrostState = , bfsProtocolParams :: Maybe (LedgerProtocolParameters ConwayEra) + , bfsStakeRewards :: Map StakeCredential (C.Quantity, Maybe PoolId) + , bfsEraHistory :: Maybe C.EraHistory -- ^ Era history } @@ -100,6 +104,7 @@ makeLensesFor , ("bfsStakePools", "stakePools") , ("bfsTxInputs", "txInputs") , ("bfsProtocolParams", "protocolParams") + , ("bfsStakeRewards", "stakeRewards") , ("bfsEraHistory", "eraHistory") ] ''BlockfrostState @@ -121,6 +126,7 @@ checkCurrentEpoch = do -- reset everything stakePools .= Nothing protocolParams .= Nothing + stakeRewards .= mempty -- the (txIn -> txOut) mapping does not change at the epoch boundary. -- So there is no risk of returning stale / incorrect data. @@ -219,3 +225,11 @@ getProtocolParams = do checkCurrentEpoch 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 + +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 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 7/8] 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 From fe91ecd67b2b0e3bc0d45024ee8f7f1413af2120 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Tue, 10 Dec 2024 08:32:55 +0100 Subject: [PATCH 8/8] More functions, review comments --- src/blockfrost/lib/Convex/Blockfrost.hs | 20 ++++++-- .../lib/Convex/Blockfrost/MonadBlockchain.hs | 46 ++++++++++--------- src/blockfrost/lib/Convex/Blockfrost/Types.hs | 9 ---- 3 files changed, 40 insertions(+), 35 deletions(-) diff --git a/src/blockfrost/lib/Convex/Blockfrost.hs b/src/blockfrost/lib/Convex/Blockfrost.hs index 0b352646..02da3196 100644 --- a/src/blockfrost/lib/Convex/Blockfrost.hs +++ b/src/blockfrost/lib/Convex/Blockfrost.hs @@ -10,6 +10,7 @@ -} module Convex.Blockfrost( BlockfrostT(..), + evalBlockfrostT, runBlockfrostT, -- * Utility functions streamUtxos @@ -25,7 +26,7 @@ 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 Convex.Blockfrost.MonadBlockchain (BlockfrostCache) import qualified Convex.Blockfrost.MonadBlockchain as MonadBlockchain import Convex.Blockfrost.Orphans () import qualified Convex.Blockfrost.Types as Types @@ -40,7 +41,7 @@ import Streaming.Prelude (Of, Stream) {-| Monad transformer that implements the @MonadBlockchain@ class using blockfrost's API -} -newtype BlockfrostT m a = BlockfrostT{ unBlockfrostT :: StateT BlockfrostState (BlockfrostClientT m) a } +newtype BlockfrostT m a = BlockfrostT{ unBlockfrostT :: StateT BlockfrostCache (BlockfrostClientT m) a } deriving newtype (Functor, Applicative, Monad, MonadIO, Types.MonadBlockfrost) -- TODO: More instances (need to be defined on BlockfrostClientT') @@ -82,8 +83,17 @@ streamUtxos a = {-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project' -} -runBlockfrostT :: MonadIO m => Project -> BlockfrostT m a -> m (Either BlockfrostError a) -runBlockfrostT proj = +evalBlockfrostT :: MonadIO m => Project -> BlockfrostT m a -> m (Either BlockfrostError a) +evalBlockfrostT proj = Types.runBlockfrostClientT proj - . flip State.evalStateT MonadBlockchain.emptyBlockfrostState + . flip State.evalStateT MonadBlockchain.emptyBlockfrostCache + . unBlockfrostT + +{-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project' and the 'BlockfrostCache' +Returns the new blockfrost state. +-} +runBlockfrostT :: MonadIO m => BlockfrostCache -> Project -> BlockfrostT m a -> m (Either BlockfrostError (a, BlockfrostCache)) +runBlockfrostT state proj = + Types.runBlockfrostClientT proj + . flip State.runStateT state . unBlockfrostT diff --git a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs index 3838ecd4..c10d6c07 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs @@ -9,8 +9,8 @@ {-| blockfrost-based implementation of MonadBlockchain -} module Convex.Blockfrost.MonadBlockchain( - BlockfrostState(..), - emptyBlockfrostState, + BlockfrostCache(..), + emptyBlockfrostCache, -- * 'MonadBlockchain' related functions sendTxBlockfrost, @@ -78,8 +78,10 @@ import qualified Ouroboros.Consensus.HardFork.History.Summary as Summary import Ouroboros.Network.Magic (NetworkMagic (..)) import qualified Streaming.Prelude as S -data BlockfrostState = - BlockfrostState +{-| Local cache of responses from Blockfrost API +-} +data BlockfrostCache = + BlockfrostCache { bfsGenesis :: Maybe Genesis , bfsEndOfEpoch :: Maybe UTCTime -- ^ End of current epoch @@ -107,12 +109,12 @@ makeLensesFor , ("bfsStakeRewards", "stakeRewards") , ("bfsEraHistory", "eraHistory") ] - ''BlockfrostState + ''BlockfrostCache {-| Check whether the next epoch has begun, and expire all short-lived data if necessary. -} -checkCurrentEpoch :: (MonadBlockfrost m, MonadState BlockfrostState m) => m () +checkCurrentEpoch :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m () checkCurrentEpoch = do epochEnd <- use endOfEpoch now <- liftIO getCurrentTime @@ -133,9 +135,10 @@ checkCurrentEpoch = do -- But we still clear the txInputs map here to avoid memory leaks. txInputs .= mempty -emptyBlockfrostState :: BlockfrostState -emptyBlockfrostState = - BlockfrostState +-- | Initial (empty) cache +emptyBlockfrostCache :: BlockfrostCache +emptyBlockfrostCache = + BlockfrostCache { bfsGenesis = Nothing , bfsEndOfEpoch = Nothing , bfsStakePools = Nothing @@ -145,7 +148,7 @@ emptyBlockfrostState = , bfsStakeRewards = Map.empty } -getGenesis :: (MonadBlockfrost m, MonadState BlockfrostState m) => m Genesis +getGenesis :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m Genesis getGenesis = getOrRetrieve genesis Client.getLedgerGenesis {-| Get a field from the state, using the action to load the value @@ -159,13 +162,13 @@ getOrRetrieve lens action = use lens >>= \case lens ?= k pure k -getSystemStart :: (MonadBlockfrost m, MonadState BlockfrostState m) => m SystemStart +getSystemStart :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m SystemStart getSystemStart = Types.systemStart <$> getGenesis -getNetworkId :: (MonadBlockfrost m, MonadState BlockfrostState m) => m NetworkId +getNetworkId :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m NetworkId getNetworkId = fromNetworkMagic . NetworkMagic . fromIntegral . Genesis._genesisNetworkMagic <$> getGenesis -getStakePools :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (Set PoolId) +getStakePools :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m (Set PoolId) getStakePools = do checkCurrentEpoch getOrRetrieve stakePools $ @@ -180,7 +183,7 @@ sendTxBlockfrost = {-| Get a single 'TxIn'. If it is not in the cache, download the entire transaction and add all of its UTxOs to the cache. -} -resolveTxIn :: (MonadBlockfrost m, MonadState BlockfrostState m) => TxIn -> m (TxOut CtxUTxO ConwayEra) +resolveTxIn :: (MonadBlockfrost m, MonadState BlockfrostCache m) => TxIn -> m (TxOut CtxUTxO ConwayEra) resolveTxIn txI@(TxIn txId (C.TxIx txIx)) = getOrRetrieve (txInputs . at txI) $ do utxos <- runExceptT (Client.getTxCBOR (Types.fromTxHash txId) >>= Types.decodeTransactionCBOR) -- FIXME: Error handling @@ -190,13 +193,13 @@ resolveTxIn txI@(TxIn txId (C.TxIx txIx)) = getOrRetrieve (txInputs . at txI) $ {-| Resolve the given tx inputs -} -getUtxoByTxIn :: (MonadBlockfrost m, MonadState BlockfrostState m) => Set TxIn -> m (UTxO ConwayEra) +getUtxoByTxIn :: (MonadBlockfrost m, MonadState BlockfrostCache m) => Set TxIn -> m (UTxO ConwayEra) getUtxoByTxIn txIns = fmap (C.UTxO . Map.fromList) $ for (Set.toList txIns) $ \txIn -> (txIn,) <$> resolveTxIn txIn {-| Get the 'EraHistory' for slot time computations -} -getEraHistory :: (MonadBlockfrost m, MonadState BlockfrostState m) => m C.EraHistory +getEraHistory :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m C.EraHistory getEraHistory = getOrRetrieve eraHistory $ do networkEras <- Client.getNetworkEras let summaries :: [Summary.EraSummary] = fmap Types.eraSummary networkEras @@ -210,7 +213,7 @@ getEraHistory = getOrRetrieve eraHistory $ do {-| Get the current slot number, slot length and UTC time of the start of the current slot. -} -getSlotNo :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (C.SlotNo, SlotLength, UTCTime) +getSlotNo :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m (C.SlotNo, SlotLength, UTCTime) getSlotNo = do (eraHistory_@(C.EraHistory interpreter), systemStart) <- (,) <$> getEraHistory <*> getSystemStart Block{_blockSlot} <- Client.getLatestBlock @@ -221,7 +224,7 @@ getSlotNo = do {-| Get the current protocol parameters -} -getProtocolParams :: (MonadBlockfrost m, MonadState BlockfrostState m) => m (LedgerProtocolParameters ConwayEra) +getProtocolParams :: (MonadBlockfrost m, MonadState BlockfrostCache m) => m (LedgerProtocolParameters ConwayEra) getProtocolParams = do checkCurrentEpoch getOrRetrieve protocolParams $ @@ -229,7 +232,7 @@ getProtocolParams = do {-| 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 :: (MonadBlockfrost m, MonadState BlockfrostCache 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) @@ -238,11 +241,12 @@ getStakeAddresses credentials = do ( 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 :: (MonadBlockfrost m, MonadState BlockfrostCache m) => C.StakeAddress -> m (C.Quantity, Maybe PoolId) getStakeRewardsSingle cred = getOrRetrieve (stakeRewards . at cred) (stakeRewardsForAddress cred) 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) + , fmap Types.poolId _accountInfoPoolId + ) diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index 7eb4617d..019f0d77 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -459,15 +459,6 @@ protocolParametersConway pp = & L.hkdA0L .~ C.unsafeBoundedRational (_protocolParamsA0 pp) -- TODO: Is unsafeBoundedRational ok to use here? & L.hkdRhoL .~ C.unsafeBoundedRational (_protocolParamsRho pp) & L.hkdTauL .~ C.unsafeBoundedRational (_protocolParamsTau pp) - -- & L.hkdDL .~ _ (_protocolParamsDecentralisationParam pp) - -- & L.hkdExtraEntropyL .~ - -- maybe BaseTypes.NeutralNonce (BaseTypes.Nonce . _) (_protocolParamsExtraEntropy pp) - -- & L.hkdExtraEntropyL .~ _ (_protocolParamsExtraEntropy pp) - -- & L.ppProtocolVersionL .~ - -- L.ProtVer - -- { L.pvMajor = _ (_protocolParamsProtocolMajorVer pp) - -- , L.pvMinor = _ (_protocolParamsProtocolMinorVer pp) - -- } & L.hkdMinPoolCostL .~ toLovelace (_protocolParamsMinPoolCost pp) & L.hkdCostModelsL .~ costModels (_protocolParamsCostModelsRaw pp) & L.hkdPricesL .~ L.Prices