Blockfrost backend for MonadBlockchain

src/blockfrost/convex-blockfrost.cabal

@@ -30,6 +30,8 @@ library
     hs-source-dirs: lib
     exposed-modules:
       Convex.Blockfrost
+      Convex.Blockfrost.MonadBlockchain
+      Convex.Blockfrost.Orphans
       Convex.Blockfrost.Types
     build-depends:
       base >= 4.14 && < 5,
@@ -42,14 +44,24 @@ 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,
       safe-money,
       cardano-binary,
       containers,
       transformers,
       streaming,
-      lens
+      time,
+      lens,
+      ouroboros-network-api,
+      ouroboros-consensus,
+      ouroboros-consensus-cardano,
+      sop-extras
 
 test-suite convex-blockfrost-test
   import: lang

src/blockfrost/lib/Convex/Blockfrost.hs

@@ -6,44 +6,43 @@
 {-# 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(..),
+  evalBlockfrostT,
   runBlockfrostT,
   -- * Utility functions
   streamUtxos
 ) where
 
-import qualified Blockfrost.Client         as Client
-import           Blockfrost.Client.Types   (BlockfrostClientT, BlockfrostError,
-                                            MonadBlockfrost (..), 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 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 (BlockfrostCache)
+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)
-
-instance MonadBlockfrost m => MonadBlockfrost (ExceptT e m) where
-  liftBlockfrostClient = lift . liftBlockfrostClient
-  getConf = lift getConf
+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')
 
@@ -59,6 +58,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)
@@ -69,18 +79,21 @@ 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)
+  $ Types.pagedStream (\p -> Client.getAddressUtxos' (Types.fromPaymentCredential a) p Client.Ascending)
 
-{-| Stream a list of results from a paged query
+{-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project'
 -}
-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))
+evalBlockfrostT :: MonadIO m => Project -> BlockfrostT m a -> m (Either BlockfrostError a)
+evalBlockfrostT proj =
+  Types.runBlockfrostClientT proj
+  . flip State.evalStateT MonadBlockchain.emptyBlockfrostCache
+  . unBlockfrostT
 
-{-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project'
+{-| Run the 'BlockfrostT' transformer using the given blockfrost 'Project' and the 'BlockfrostCache'
+Returns the new blockfrost state.
 -}
-runBlockfrostT :: MonadIO m => Project -> BlockfrostT m a -> m (Either BlockfrostError a)
-runBlockfrostT proj = Types.runBlockfrostClientT proj . unBlockfrostT
+runBlockfrostT :: MonadIO m => BlockfrostCache -> Project -> BlockfrostT m a -> m (Either BlockfrostError (a, BlockfrostCache))
+runBlockfrostT state proj =
+  Types.runBlockfrostClientT proj
+  . flip State.runStateT state
+  . unBlockfrostT