From db5f57c4c96398c6009fa96db37fa76f0b5e2a9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jann=20M=C3=BCller?= Date: Fri, 13 Dec 2024 11:25:58 +0100 Subject: [PATCH] Add Convex.FullTx --- src/base/convex-base.cabal | 4 +- src/base/lib/Convex/FullTx.hs | 136 ++++++++++++++++++++++++ src/base/lib/Convex/Utils.hs | 24 ++++- src/base/lib/Convex/UtxoMod.hs | 52 ++------- src/blockfrost/lib/Convex/Blockfrost.hs | 2 +- 5 files changed, 171 insertions(+), 47 deletions(-) create mode 100644 src/base/lib/Convex/FullTx.hs diff --git a/src/base/convex-base.cabal b/src/base/convex-base.cabal index 549939ae..2935ca24 100644 --- a/src/base/convex-base.cabal +++ b/src/base/convex-base.cabal @@ -32,6 +32,7 @@ library Convex.Class Convex.Constants Convex.Eon + Convex.FullTx Convex.MonadLog Convex.NodeQueries Convex.NodeQueries.Debug @@ -84,7 +85,8 @@ library bytestring, dlist, either-result, - strict-sop-core + strict-sop-core, + graphviz test-suite convex-base-test import: lang diff --git a/src/base/lib/Convex/FullTx.hs b/src/base/lib/Convex/FullTx.hs new file mode 100644 index 00000000..0da8923f --- /dev/null +++ b/src/base/lib/Convex/FullTx.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-| Working with fully resolved transactions +-} +module Convex.FullTx( + FullTx(..), + -- * Visualising transactions + dot, + dotFile +) where + +import qualified Cardano.Api as C +import Control.Monad.Reader (ReaderT, asks, lift, + runReaderT) +import qualified Convex.Utils as Utils +import Data.Aeson (FromJSON (..), + ToJSON (..), withObject, + (.:)) +import Data.Aeson.Types (object, (.=)) +import Data.Foldable (traverse_) +import Data.GraphViz.Attributes (bgColor, filled, style) +import qualified Data.GraphViz.Attributes.Colors.X11 as Colors +import qualified Data.GraphViz.Attributes.Complete as A +import Data.GraphViz.Printing (PrintDot (..)) +import qualified Data.GraphViz.Types as GVT +import Data.GraphViz.Types.Generalised (DotGraph (..)) +import qualified Data.GraphViz.Types.Monadic as GV +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import qualified Data.Text.Lazy as TL +import GHC.Generics (Generic) + +{-| A transaction with fully resolved inputs. +To obtain a 'FullTx' value see 'Convex.Blockfrost.resolveFullTx' +-} +data FullTx = + FullTx + { ftxTransaction :: C.Tx C.ConwayEra -- ^ The transaction + , ftxInputs :: Map C.TxIn (C.TxOut C.CtxUTxO C.ConwayEra) -- ^ The set of spend, reference and collateral inputs of the transaction + } + deriving stock (Eq, Show, Generic) + +{-| The transaction's body content +-} +txBodyContent :: FullTx -> C.TxBodyContent C.ViewTx C.ConwayEra +txBodyContent FullTx{ftxTransaction} = + let (C.Tx (C.TxBody content) _witnesses) = ftxTransaction + in content + +instance ToJSON FullTx where + toJSON FullTx{ftxTransaction, ftxInputs} = + object + [ "transaction" .= C.serialiseToTextEnvelope Nothing ftxTransaction + , "inputs" .= ftxInputs + ] + +instance FromJSON FullTx where + parseJSON = withObject "FullTx" $ \obj -> + FullTx + <$> (obj .: "transaction" >>= either (fail . show) pure . C.deserialiseFromTextEnvelope (C.proxyToAsType Proxy)) + <*> obj .: "inputs" + +{-| A .dot (graphviz) representation of the transaction +-} +dot :: FullTx -> Text +dot tx@FullTx{ftxTransaction} = TL.toStrict $ GVT.printDotGraph $ dot' (C.textShow $ C.getTxId $ C.getTxBody ftxTransaction) tx + +{-| Write the transaction graph to a .dot (graphviz) file +-} +dotFile :: FilePath -> FullTx -> IO () +dotFile fp = TIO.writeFile fp . dot + +data FullTxInput = + RefInput C.TxIn + | SpendInput C.TxIn + | CollateralInput C.TxIn + deriving stock (Eq, Ord, Show) + +fullTxInputLabel :: FullTxInput -> A.RecordField +fullTxInputLabel = \case + RefInput i -> A.FieldLabel $ TL.fromStrict $ C.renderTxIn i + SpendInput i -> A.FieldLabel $ TL.fromStrict $ C.renderTxIn i + CollateralInput i -> A.FieldLabel $ TL.fromStrict $ C.renderTxIn i + +instance GVT.PrintDot FullTxInput where + unqtDot = \case + RefInput txI -> unqtDot ("ref-" <> C.renderTxIn txI) + SpendInput txI -> unqtDot ("spend-" <> C.renderTxIn txI) + CollateralInput txI -> unqtDot ("collateral-" <> C.renderTxIn txI) + +{-| Object that we display in the graph +-} +data FullTxObject = + FtxInput FullTxInput + | FullTxBody + | FullTxOutput Integer + deriving stock (Eq, Ord, Show) + +instance GVT.PrintDot FullTxObject where + unqtDot = \case + FtxInput it -> unqtDot it + FullTxBody -> unqtDot @String "txbody" + FullTxOutput idx -> unqtDot ("output" <> show idx) + +dot' :: Text -> FullTx -> DotGraph FullTxObject +dot' (TL.fromStrict -> nm) ftx = GV.digraph (GV.Str nm) $ do + GV.graphAttrs [ A.RankDir A.FromLeft ] + GV.nodeAttrs + [ A.Shape A.Record + , style filled + , bgColor Colors.Gray93 + , A.Height 0.1 + ] + flip runReaderT ftx $ do + addTxBody + asks (Utils.spendInputs . txBodyContent) >>= traverse_ (addInput . SpendInput) + asks (Utils.referenceInputs . txBodyContent) >>= traverse_ (addInput . RefInput) + asks (Utils.collateralInputs . txBodyContent) >>= traverse_ (addInput . CollateralInput) + +type GraphBuilder a = ReaderT FullTx (GV.DotM FullTxObject) a + +addInput :: FullTxInput -> GraphBuilder () +addInput txI = do + lift $ do + let ref = FtxInput txI + GV.node ref [A.Label $ A.RecordLabel [fullTxInputLabel txI]] + GV.edge ref FullTxBody [] + +addTxBody :: GraphBuilder () +addTxBody = lift $ GV.node FullTxBody [A.Label $ A.RecordLabel [A.FieldLabel "tx body"]] diff --git a/src/base/lib/Convex/Utils.hs b/src/base/lib/Convex/Utils.hs index 01c1594f..8df86eae 100644 --- a/src/base/lib/Convex/Utils.hs +++ b/src/base/lib/Convex/Utils.hs @@ -20,6 +20,9 @@ module Convex.Utils( -- * Transaction inputs requiredTxIns, + spendInputs, + collateralInputs, + referenceInputs, -- * Serialised transactions txFromCbor, @@ -309,10 +312,25 @@ alonzoEraUtxo f = case C.alonzoBasedEra @era of C.AlonzoEraOnwardsBabbage -> f C.AlonzoEraOnwardsConway -> f +{-| Inputs consumed by the transaction +-} +spendInputs :: C.TxBodyContent v era -> Set C.TxIn +spendInputs = Set.fromList . fmap fst . view L.txIns + +{-| Inputs used as reference inputs +-} +referenceInputs :: C.TxBodyContent v era -> Set C.TxIn +referenceInputs = Set.fromList . view (L.txInsReference . L.txInsReferenceTxIns) + +{-| Inputs used as collateral inputs +-} +collateralInputs :: C.TxBodyContent v era -> Set C.TxIn +collateralInputs = Set.fromList . view (L.txInsCollateral . L.txInsCollateralTxIns) + {-| All 'TxIn's that are required for computing the balance and fees of a transaction -} requiredTxIns :: C.TxBodyContent v era -> Set C.TxIn requiredTxIns body = - Set.fromList (fst <$> view L.txIns body) - <> Set.fromList (view (L.txInsReference . L.txInsReferenceTxIns) body) - <> Set.fromList (view (L.txInsCollateral . L.txInsCollateralTxIns) body) + spendInputs body + <> referenceInputs body + <> collateralInputs body diff --git a/src/base/lib/Convex/UtxoMod.hs b/src/base/lib/Convex/UtxoMod.hs index fc20fdb8..6114d14c 100644 --- a/src/base/lib/Convex/UtxoMod.hs +++ b/src/base/lib/Convex/UtxoMod.hs @@ -10,23 +10,18 @@ module Convex.UtxoMod( replaceHash, tryReplaceHash, - replaceHashAnyLang, - FullTx(..) + replaceHashAnyLang ) where -import Cardano.Api (Hash, Script, ScriptHash, - ScriptInAnyLang (..)) -import qualified Cardano.Api as C -import Cardano.Binary (DecoderError) -import Control.Monad (guard) -import Data.Aeson (FromJSON (..), ToJSON (..), withObject, (.:)) -import Data.Aeson.Types (object, (.=)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Functor (($>)) -import Data.Map (Map) -import Data.Proxy (Proxy (..)) -import GHC.Generics (Generic) +import Cardano.Api (Hash, Script, ScriptHash, + ScriptInAnyLang (..)) +import qualified Cardano.Api as C +import Cardano.Binary (DecoderError) +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Functor (($>)) +import Data.Proxy (Proxy (..)) {-| Replace all occurrences of a hash in the serialised script with a new hash. Throws an 'error' if it fails @@ -90,30 +85,3 @@ replaceHashAnyLang oldHash newHash = \case let oldScriptHash = C.hashScript script newScriptHash = C.hashScript new pure (C.ScriptInAnyLang (C.PlutusScriptLanguage C.PlutusScriptV3) new, guard (oldScriptHash /= newScriptHash) $> newScriptHash) - --- TODO --- 1. Download a full "spending transaction" --- - the transaction --- - all inputs and outputs - -{-| A transaction with fully resolved inputs --} -data FullTx = - FullTx - { ftxTransaction :: C.Tx C.ConwayEra - , ftxInputs :: Map C.TxIn (C.TxOut C.CtxUTxO C.ConwayEra) - } - deriving stock (Eq, Show, Generic) - -instance ToJSON FullTx where - toJSON FullTx{ftxTransaction, ftxInputs} = - object - [ "transaction" .= C.serialiseToTextEnvelope Nothing ftxTransaction - , "inputs" .= ftxInputs - ] - -instance FromJSON FullTx where - parseJSON = withObject "FullTx" $ \obj -> - FullTx - <$> (obj .: "transaction" >>= either (fail . show) pure . C.deserialiseFromTextEnvelope (C.proxyToAsType Proxy)) - <*> obj .: "inputs" diff --git a/src/blockfrost/lib/Convex/Blockfrost.hs b/src/blockfrost/lib/Convex/Blockfrost.hs index 6cc1c344..a45e20a4 100644 --- a/src/blockfrost/lib/Convex/Blockfrost.hs +++ b/src/blockfrost/lib/Convex/Blockfrost.hs @@ -38,8 +38,8 @@ import Convex.Blockfrost.Orphans () import qualified Convex.Blockfrost.Types as Types import Convex.Class (MonadBlockchain (..), MonadUtxoQuery (..)) +import Convex.FullTx (FullTx (..)) import Convex.Utils (requiredTxIns) -import Convex.UtxoMod (FullTx (..)) import qualified Convex.Utxos as Utxos import Data.Bifunctor (Bifunctor (..)) import qualified Data.Set as Set