diff --git a/src/base/lib/Convex/Utxos.hs b/src/base/lib/Convex/Utxos.hs index 24b0fb17..992cd43c 100644 --- a/src/base/lib/Convex/Utxos.hs +++ b/src/base/lib/Convex/Utxos.hs @@ -21,6 +21,7 @@ module Convex.Utxos( UtxoSet(..), fromUtxoTx, singleton, + fromList, PrettyBalance(..), _UtxoSet, totalBalance, @@ -211,6 +212,11 @@ instance TxOutConstraints FromJSON ctx => FromJSON (C.InAnyCardanoEra (C.TxOut c singleton :: CS.IsCardanoEra era => TxIn -> (C.TxOut ctx era, a) -> UtxoSet ctx a singleton txi = UtxoSet . Map.singleton txi . first (C.InAnyCardanoEra C.cardanoEra) +{-| @Map.fromList@ +-} +fromList :: CS.IsCardanoEra era => [(TxIn, (C.TxOut ctx era, a))] -> UtxoSet ctx a +fromList = UtxoSet . Map.fromList . fmap (second (first (C.InAnyCardanoEra C.cardanoEra))) + {-| Change the context of the outputs in this utxo set to 'CtxUTxO' -} fromUtxoTx :: UtxoSet C.CtxTx a -> UtxoSet C.CtxUTxO a diff --git a/src/blockfrost/convex-blockfrost.cabal b/src/blockfrost/convex-blockfrost.cabal index 5f10416e..7b26ea51 100644 --- a/src/blockfrost/convex-blockfrost.cabal +++ b/src/blockfrost/convex-blockfrost.cabal @@ -30,7 +30,6 @@ library hs-source-dirs: lib exposed-modules: Convex.Blockfrost - Convex.Blockfrost.API Convex.Blockfrost.Types build-depends: base >= 4.14 && < 5, @@ -49,6 +48,7 @@ library cardano-binary, containers, transformers, + streaming, lens test-suite convex-blockfrost-test diff --git a/src/blockfrost/lib/Convex/Blockfrost.hs b/src/blockfrost/lib/Convex/Blockfrost.hs index 5561cca0..2ba4cd61 100644 --- a/src/blockfrost/lib/Convex/Blockfrost.hs +++ b/src/blockfrost/lib/Convex/Blockfrost.hs @@ -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 diff --git a/src/blockfrost/lib/Convex/Blockfrost/API.hs b/src/blockfrost/lib/Convex/Blockfrost/API.hs deleted file mode 100644 index 938a2bcd..00000000 --- a/src/blockfrost/lib/Convex/Blockfrost/API.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-| Blockfrost API --} -module Convex.Blockfrost.API( - -) where - diff --git a/src/blockfrost/lib/Convex/Blockfrost/Types.hs b/src/blockfrost/lib/Convex/Blockfrost/Types.hs index 5fe49b6e..1e1e1505 100644 --- a/src/blockfrost/lib/Convex/Blockfrost/Types.hs +++ b/src/blockfrost/lib/Convex/Blockfrost/Types.hs @@ -21,6 +21,7 @@ module Convex.Blockfrost.Types( TxOutUnresolvedScript(..), utxoOutput, addressUtxo, + addressUtxoTxIn, ScriptResolutionFailure(..), resolveScript, -- * CBOR @@ -50,6 +51,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 Cardano.Api.SerialiseUsing (UsingRawBytesHex (..)) import Cardano.Api.Shelley (Lovelace) import qualified Cardano.Api.Shelley as C import Cardano.Binary (DecoderError) @@ -86,16 +88,22 @@ toTxHash = textToIsString textToIsString :: (Coercible a Text.Text, IsString b) => a -> b textToIsString = fromString . Text.unpack . coerce +hexTextToByteString :: C.SerialiseAsRawBytes a => Text.Text -> a +hexTextToByteString t = + let UsingRawBytesHex x = fromString (Text.unpack t) + in x + toAssetId :: Amount -> (C.AssetId, C.Quantity) toAssetId = \case AdaAmount lvl -> (C.AdaAssetId, C.lovelaceToQuantity $ toLovelace lvl) AssetAmount disc -> -- concatenation of asset policy ID and hex-encoded asset_name - let (policyText, assetName) = Text.splitAt 56 (Money.someDiscreteCurrency disc) + let txt = Money.someDiscreteCurrency disc + (policyText, assetName) = Text.splitAt 56 txt amount = Money.someDiscreteAmount disc -- TODO: We could also consider Money.someDiscreteScale -- but it looks like blockfrost just uses unitScale for native assets - in (C.AssetId (textToIsString policyText) (textToIsString assetName), C.Quantity amount) + in (C.AssetId (textToIsString policyText) (hexTextToByteString assetName), C.Quantity amount) toAddress :: C.IsCardanoEra era => Address -> Maybe (C.AddressInEra era) toAddress (Address text) = C.deserialiseAddress (C.proxyToAsType Proxy) text @@ -118,7 +126,7 @@ instance C.HasTypeProxy a => C.HasTypeProxy (CustomBech32 a) where instance C.SerialiseAsRawBytes a => C.SerialiseAsRawBytes (CustomBech32 a) where serialiseToRawBytes (CustomBech32 a) = C.serialiseToRawBytes a - deserialiseFromRawBytes asType = fmap CustomBech32 . C.deserialiseFromRawBytes (proxyToAsType Proxy) + deserialiseFromRawBytes _asType = fmap CustomBech32 . 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 @@ -186,10 +194,10 @@ resolveScript TxOutUnresolvedScript{txuOutput, txuScriptHash} = runExceptT $ inB PlutusV3 -> do s <- either (throwError . FailedToDeserialise _scriptType txuScriptHash . show) pure (C.deserialiseFromRawBytesHex (C.proxyToAsType $ Proxy @(C.PlutusScript C.PlutusScriptV3)) (Text.Encoding.encodeUtf8 text)) pure (C.ReferenceScript (C.babbageBasedEra @era) (C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV3) (C.PlutusScript C.PlutusScriptV3 s))) - -- Timelock -> undefined -- Simple script + Timelock -> + error "resolveScript: Not implemented: Timelock" + undefined -- Simple script return (txuOutput & L._TxOut . _4 .~ refScript) - -- let refScript = C.ReferenceScript C.babbageBasedEra - -- undefined {-| Convert a blockfrost 'UtxoOutput' to a @cardano-api@ 'C.TxOut C.CtxUTxO era', @@ -220,6 +228,12 @@ convertOutput addr_ amount dataHash inlineDatum refScriptHash = inBabbage @era $ Just txuScriptHash -> Left TxOutUnresolvedScript{txuOutput, txuScriptHash} +{-| The utxo reference 'C.TxIn' of the 'AddressUtxo' +-} +addressUtxoTxIn :: AddressUtxo -> C.TxIn +addressUtxoTxIn AddressUtxo{_addressUtxoTxHash, _addressUtxoOutputIndex} = + C.TxIn (toTxHash _addressUtxoTxHash) (C.TxIx $ fromIntegral _addressUtxoOutputIndex) + {-| Convert a blockfrost 'AddressUtxo' to a @cardano-api@ 'C.TxOut C.CtxUTxO era', returning 'TxOutUnresolvedScript' if the output has a reference script. -} diff --git a/src/blockfrost/test/Unit.hs b/src/blockfrost/test/Unit.hs index 48b14def..aeaa57ef 100644 --- a/src/blockfrost/test/Unit.hs +++ b/src/blockfrost/test/Unit.hs @@ -31,7 +31,11 @@ tests = testGroup "unit" , testCase "amount" $ assertEqual "asset ID should match" (toAssetId $ AssetAmount $ Money.toSomeDiscrete (12 :: Money.Discrete' "b0d07d45fe9514f80213f4020e5a61241458be626841cde717cb38a76e7574636f696e" '(1, 1))) - (C.AssetId "b0d07d45fe9514f80213f4020e5a61241458be626841cde717cb38a7" "6e7574636f696e", 12) + + -- Note the difference in the asset names ('nutcoin' vs '6e7574636f696e') + -- This is because the 'FromString' instance of AssetName uses the UTF8 encoding of the string (which doesn't make sense for script hash token names) + -- whereas blockfrost gives us the hex encoded bytestring + (C.AssetId "b0d07d45fe9514f80213f4020e5a61241458be626841cde717cb38a7" "nutcoin", 12) , testCase "address" $ deserialiseAddress "addr1qxqs59lphg8g6qndelq8xwqn60ag3aeyfcp33c2kdp46a09re5df3pzwwmyq946axfcejy5n4x0y99wqpgtp2gd0k09qsgy6pz" , testCase "stake address" diff --git a/src/node-client/convex-node-client.cabal b/src/node-client/convex-node-client.cabal index 2e4f4859..64a50aa7 100644 --- a/src/node-client/convex-node-client.cabal +++ b/src/node-client/convex-node-client.cabal @@ -43,8 +43,7 @@ library containers, aeson, stm, - mtl, - primitive + mtl build-depends: convex-base