Skip to content

Commit

Permalink
Add MonadBlockchain instance to BlockfrostT
Browse files Browse the repository at this point in the history
  • Loading branch information
@j-mueller
j-mueller committed Dec 9, 2024
1 parent e6a3638 commit 96d8215
Show file tree
Hide file tree
Showing 4 changed files with 133 additions and 74 deletions.
58 changes: 38 additions & 20 deletions src/blockfrost/lib/Convex/Blockfrost.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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')

Expand All @@ -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)
Expand All @@ -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
81 changes: 47 additions & 34 deletions src/blockfrost/lib/Convex/Blockfrost/MonadBlockchain.hs
View file
Original file line number Diff line number Diff line change
@@ -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 (..),
Expand All @@ -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)
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -142,6 +142,7 @@ emptyBlockfrostState =
, bfsTxInputs = Map.empty
, bfsProtocolParams = Nothing
, bfsEraHistory = Nothing
, bfsStakeRewards = Map.empty
}

getGenesis :: (MonadBlockfrost m, MonadState BlockfrostState m) => m Genesis
Expand Down Expand Up @@ -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)

Expand All @@ -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)
11 changes: 8 additions & 3 deletions src/blockfrost/lib/Convex/Blockfrost/Orphans.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
57 changes: 40 additions & 17 deletions src/blockfrost/lib/Convex/Blockfrost/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,7 @@ module Convex.Blockfrost.Types(
decodeTransactionCBOR,
-- * Payment credential
fromPaymentCredential,
fromStakeAddress,
-- * Genesis related
systemStart,
-- * Misc.
Expand Down Expand Up @@ -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 (..))
Expand All @@ -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,
Expand All @@ -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)

Expand Down Expand Up @@ -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
Expand All @@ -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

Expand Down

0 comments on commit 96d8215

Please sign in to comment.