Add Convex.FullTx

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

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"]]

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

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"

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