-
Notifications
You must be signed in to change notification settings - Fork 14
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
7 changed files
with
93 additions
and
44 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,54 +1,86 @@ | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE GADTs #-} | ||
| {-# LANGUAGE LambdaCase #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TupleSections #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
| {-# LANGUAGE UndecidableInstances #-} | ||
|
|
||
| -- Need this because of missing instances for BlockfrostClientT | ||
| {-# OPTIONS_GHC -Wno-orphans #-} | ||
| {-| Blockfrost-backed implementation of @MonadBlockchain@ | ||
| -} | ||
| module Convex.Blockfrost( | ||
| BlockfrostT(..) | ||
| BlockfrostT(..), | ||
| runBlockfrostT, | ||
| -- * Utility functions | ||
| streamUtxos | ||
| ) where | ||
|
|
||
| import qualified Blockfrost.Client as Client | ||
| import Blockfrost.Client.Types (BlockfrostClientT) | ||
| import Blockfrost.Client.Types (BlockfrostClientT, BlockfrostError, | ||
| MonadBlockfrost (..), Project) | ||
| import qualified Blockfrost.Client.Types as Types | ||
| import qualified Cardano.Api as C | ||
| import Control.Monad (join) | ||
| import Control.Monad.Error.Class (MonadError) | ||
| import Control.Monad ((>=>)) | ||
| import Control.Monad.Except (ExceptT (..), liftEither, | ||
| runExceptT) | ||
| import Control.Monad.IO.Class (MonadIO (..)) | ||
| import Control.Monad.Primitive (PrimMonad) | ||
| import Control.Monad.Trans.Class (MonadTrans (..)) | ||
| import qualified Convex.Blockfrost.Types as Types | ||
| import Convex.Class (MonadBlockchain (..), | ||
| MonadUtxoQuery (..)) | ||
| 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) | ||
|
|
||
| {-| Monad transformer that implements the @MonadBlockchain@ | ||
| class using blockfrost's API | ||
| -} | ||
| newtype BlockfrostT m a = BlockfrostT{ runBlockfrostT :: BlockfrostClientT m a } | ||
| newtype BlockfrostT m a = BlockfrostT{ unBlockfrostT :: BlockfrostClientT m a } | ||
| deriving newtype (Functor, Applicative, Monad, MonadIO) | ||
|
|
||
| instance MonadIO m => MonadBlockchain C.ConwayEra (BlockfrostT m) where | ||
| -- FIXME: Implement | ||
| sendTx = undefined | ||
| -- sendTx = BlockfrostT . fmap (Right . Types.toTxHash) . Client.submitTx . Types.toCBORString . undefined | ||
| instance MonadBlockfrost m => MonadBlockfrost (ExceptT e m) where | ||
| liftBlockfrostClient = lift . liftBlockfrostClient | ||
| getConf = lift getConf | ||
|
|
||
| utxoByTxIn = undefined | ||
| queryProtocolParameters = undefined | ||
| queryStakeAddresses = undefined | ||
| queryStakePools = undefined | ||
| querySystemStart = undefined | ||
| queryEraHistory = undefined | ||
| querySlotNo = undefined | ||
| queryNetworkId = undefined | ||
| -- TODO: More instances (need to be defined on BlockfrostClientT') | ||
|
|
||
| instance MonadIO m => MonadUtxoQuery (BlockfrostT m) where | ||
| utxosByPaymentCredentials credentials = BlockfrostT $ do | ||
| let addresses = Set.toList credentials | ||
| paged = Client.Paged{Client.countPerPage = 10000, Client.pageNumber = 1} | ||
| results <- | ||
| fmap (second $ Types.addressUtxo @C.ConwayEra) | ||
| . join | ||
| <$> traverse (\a -> fmap (a,) <$> Client.getAddressUtxos' (Types.fromPaymentCredential a) paged Client.Ascending) addresses | ||
| results' <- traverse (traverse (either Types.resolveScript (pure . Right))) results | ||
| -- _ results | ||
| undefined | ||
| results' <- S.toList_ $ S.for (S.each addresses) $ \paymentCredential -> | ||
| -- TODO: by using 'mapMaybe' we simply drop the outputs that have script resolution failures | ||
| -- We should at least log them | ||
| S.mapMaybe (either (const Nothing) Just) $ streamUtxos paymentCredential | ||
|
|
||
| pure | ||
| $ Utxos.fromList @C.ConwayEra | ||
| $ fmap (second (, Nothing)) results' | ||
|
|
||
| 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) | ||
| pure (Types.addressUtxoTxIn addr, k) | ||
|
|
||
| {-| Load all UTxOs for a payment credential in a stream. This includes resolution of reference scripts with 'Types.resolveScript' | ||
| -} | ||
| 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)) | ||
|
|
||
| {-| 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 |
This file was deleted.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -43,8 +43,7 @@ library | |
| containers, | ||
| aeson, | ||
| stm, | ||
| mtl, | ||
| primitive | ||
| mtl | ||
|
|
||
| build-depends: | ||
| convex-base | ||
|
|
||