Add tools for downloading and modifying transactions

.gitignore

@@ -31,3 +31,6 @@ haddocks/
 get-protocol-parameters.sh
 protocol-parameters-mainnet.json
 .pre-commit-config.yaml
+download-tx-test.sh
+tx.json
+graph.dot

README.md

@@ -8,6 +8,7 @@ A collection of libraries that are helpful for building Cardano apps with Haskel
 * `convex-coin-selection`: Coin selection and transaction balancing
 * `convex-mockchain`: Minimal mockchain for tests
 * `convex-optics`: Some optics for plutus-ledger-api and cardano-api
+* `convex-tx-mod`: Command-line tool for working with transactions
 
 The API documentation (Haddocks) is published [here](https://j-mueller.github.io/sc-tools/)
 
@@ -22,6 +23,22 @@ The `main` branch uses the following versions of its major dependencies:
 |`ghc`|9.6.6|
 |`cabal`|3.10.3.0|
 
+## Evaluating Transactions
+
+The command-line tool `convex-tx-mod` can be used to download and analyse fully resolved transactions from blockfrost. Example:
+
+```shell
+export BLOCKFROST_TOKEN=<blockfrost_token>
+convex-tx-mod download bba17fd7b99fd88e5cfffb3223cf3988367f5fa7371f6549474310b0453e4c0a -o tx.json
+convex-tx-mod graph -f tx.json -o graph.dot
+```
+
+Note that the `BLOCKFROST_TOKEN` variable must be set to a token for the network that the transaction is from (ie mainnet, preprod).
+
+This downloads the serialised transaction and all its inputs to `tx.json` and then generates a dot graph in `graph.dot`.
+
+![](docs/img/example-transaction.svg)
+
 ## Building transactions
 
 We use the `TxBodyContent BuildTx BabbageEra` type from `cardano-api` as the basic type for building transactions. The `MonadBuildTx` class from `Convex.BuildTx` is essentially a writer for `TxBodyContent` modifications. `Convex.BuildTx` defines a number of helper functions for common tasks such as spending and creating Plutus script outputs, minting native assets, setting collateral, etc.

cabal.project

@@ -34,4 +34,5 @@ packages:
   src/mockchain
   src/node-client
   src/optics
+  src/tx-mod
   src/wallet

src/base/convex-base.cabal

@@ -39,8 +39,10 @@ library
       Convex.PlutusLedger.V1
       Convex.PlutusLedger.V3
       Convex.PlutusTx
+      Convex.ResolvedTx
       Convex.Utils
       Convex.Utxos
+      Convex.UtxoMod
     hs-source-dirs: lib
     build-depends:
       base >= 4.14 && < 4.20,
@@ -64,13 +66,15 @@ library
       cardano-api == 10.1.0.0,
       cardano-ledger-core,
       cardano-crypto-wrapper,
+      cardano-binary,
 
       cardano-ledger-byron,
       cardano-ledger-mary,
       cardano-ledger-shelley,
       cardano-ledger-babbage,
       cardano-ledger-alonzo,
       cardano-ledger-conway,
+      cardano-crypto-class,
 
       ouroboros-consensus,
       ouroboros-consensus-cardano,
@@ -82,7 +86,9 @@ library
       bytestring,
       dlist,
       either-result,
-      strict-sop-core
+      strict-sop-core,
+      graphviz,
+      base16-bytestring
 
 test-suite convex-base-test
   import: lang

src/base/lib/Convex/ResolvedTx.hs

@@ -0,0 +1,248 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE NamedFieldPuns     #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE TypeApplications   #-}
+{-# LANGUAGE ViewPatterns       #-}
+{-| Working with fully resolved transactions
+-}
+module Convex.ResolvedTx(
+  ResolvedTx(..),
+  -- * Visualising transactions
+  dot,
+  dotFile
+) where
+
+import qualified Cardano.Api                         as C
+import           Cardano.Crypto.Hash                 (hashToTextAsHex)
+import qualified Cardano.Ledger.Credential           as Credential
+import           Cardano.Ledger.Hashes               (ScriptHash (..))
+import           Cardano.Ledger.Keys                 (KeyHash (..))
+import           Cardano.Ledger.Shelley.API          (Coin (..))
+import           Control.Lens                        (_1, _2, preview, view)
+import           Control.Monad.Reader                (ReaderT, asks, lift,
+                                                      runReaderT)
+import           Convex.CardanoApi.Lenses            (_ShelleyAddress, _TxOut,
+                                                      _TxOutValue)
+import qualified Convex.CardanoApi.Lenses            as L
+import qualified Convex.Utils                        as Utils
+import           Data.Aeson                          (FromJSON (..),
+                                                      ToJSON (..), withObject,
+                                                      (.:))
+import           Data.Aeson.Types                    (object, (.=))
+import           Data.Bifunctor                      (Bifunctor (second))
+import qualified Data.ByteString.Base16              as Base16
+import           Data.Foldable                       (forM_, traverse_)
+import           Data.GraphViz.Attributes            (bgColor)
+import qualified Data.GraphViz.Attributes            as A
+import qualified Data.GraphViz.Attributes.Colors.X11 as Colors
+import qualified Data.GraphViz.Attributes.Complete   as A
+import           Data.GraphViz.Printing              (DotCode, 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 qualified Data.Map                            as Map
+import           Data.Proxy                          (Proxy (..))
+import           Data.Text                           (Text)
+import qualified Data.Text                           as Text
+import qualified Data.Text.Encoding                  as Text
+import qualified Data.Text.IO                        as TIO
+import qualified Data.Text.Lazy                      as TL
+import           GHC.Generics                        (Generic)
+import           GHC.IsList                          (IsList (..))
+
+{-| A transaction with fully resolved inputs.
+To obtain a 'ResolvedTx' value see 'Convex.Blockfrost.resolveTx'
+-}
+data ResolvedTx =
+  ResolvedTx
+    { rtxTransaction :: C.Tx C.ConwayEra -- ^ The transaction
+    , rtxInputs      :: 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 :: ResolvedTx -> C.TxBodyContent C.ViewTx C.ConwayEra
+txBodyContent ResolvedTx{rtxTransaction} =
+  let (C.Tx (C.TxBody content) _witnesses) = rtxTransaction
+  in content
+
+txId :: ResolvedTx -> C.TxId
+txId = C.getTxId . C.getTxBody . rtxTransaction
+
+instance ToJSON ResolvedTx where
+  toJSON ResolvedTx{rtxTransaction, rtxInputs} =
+    object
+      [ "transaction" .= C.serialiseToTextEnvelope Nothing rtxTransaction
+      , "inputs"      .= rtxInputs
+      ]
+
+instance FromJSON ResolvedTx where
+  parseJSON = withObject "ResolvedTx" $ \obj ->
+    ResolvedTx
+      <$> (obj .: "transaction" >>= either (fail . show) pure . C.deserialiseFromTextEnvelope (C.proxyToAsType Proxy))
+      <*> obj .: "inputs"
+
+{-| A .dot (graphviz) representation of the transaction
+-}
+dot :: [ResolvedTx] -> Text
+dot = TL.toStrict . GVT.printDotGraph . dot' "resolved-transactions"
+
+{-| Write the transaction graph to a .dot (graphviz) file
+-}
+dotFile :: FilePath -> [ResolvedTx] -> IO ()
+dotFile fp = TIO.writeFile fp . dot
+
+data FullTxInput =
+  RefInput C.TxIn
+  | SpendInput C.TxIn
+  | CollateralInput C.TxIn
+  deriving stock (Eq, Ord, Show)
+
+getTxIn :: FullTxInput -> C.TxIn
+getTxIn = \case
+  RefInput i -> i
+  SpendInput i -> i
+  CollateralInput i -> i
+
+addressLabel :: C.IsShelleyBasedEra era => C.TxOut ctx era -> A.RecordField
+addressLabel txo = case preview (_TxOut . _1 . _ShelleyAddress . _2) txo of
+  Just (Credential.KeyHashObj (KeyHash has))       -> A.FieldLabel $ TL.fromStrict $ "pubkey " <> shortenHash56 (hashToTextAsHex has)
+  Just (Credential.ScriptHashObj (ScriptHash has)) -> A.FieldLabel $ TL.fromStrict $ "script " <> shortenHash56 (hashToTextAsHex has)
+  _                                                -> A.FieldLabel "(byron)"
+
+fullTxOutputLabel :: (C.IsMaryBasedEra era) => C.TxIn -> C.TxOut ctx era -> [A.RecordField]
+fullTxOutputLabel i txOut =
+  [ A.FieldLabel $ TL.fromStrict $ shortenHash $ C.renderTxIn i
+  , addressLabel txOut
+  , valueLabel txOut
+  ]
+
+adaLabel :: Integer -> Text
+adaLabel ada =
+  let (n, k) = ada `divMod` 1_000_000
+      (n2, k2) = k `divMod` 10
+      (n3, _)  = k2 `divMod` 10
+  in "Ada: " <> Text.pack (show n) <> "." <> Text.pack (show n2) <> Text.pack (show n3)
+
+valueLabel :: (C.IsMaryBasedEra era) => C.TxOut ctx era -> A.RecordField
+valueLabel =
+  let renderAsset C.AdaAssetId (C.Quantity n)                   = adaLabel n
+      renderAsset (C.AssetId C.PolicyId{C.unPolicyId} (C.AssetName assetName)) (C.Quantity n) =
+        let lbl = shortenHash56 (Text.pack $ filter ((/=) '"') $ show unPolicyId) <> "." <> Text.decodeUtf8 (Base16.encode assetName)
+        in lbl <> ": " <> Text.pack (show n)
+      renderValue = Text.unlines . fmap (uncurry renderAsset) . toList
+  in A.FieldLabel . TL.fromStrict . renderValue . view (_TxOut . _2 . _TxOutValue)
+
+{-| Replace the hash sign with an underscore. This is required so that 'TxId's can be used
+as node identifiers in .dot
+-}
+replaceHash :: Text -> Text
+replaceHash = Text.replace "#" "_"
+
+{-| Shorten a 64 character hash value by taking only the first and last
+four characters
+-}
+shortenHash :: Text -> Text
+shortenHash t = Text.take 4 t <> "..." <> Text.drop 60 t
+
+{-| Shorten a 56 character hash value by taking only the first and last
+four characters
+-}
+shortenHash56 :: Text -> Text
+shortenHash56 t = Text.take 4 t <> "..." <> Text.drop 52 t
+
+instance GVT.PrintDot FullTxInput where
+  unqtDot = \case
+    RefInput txI -> mkTxInLabel txI
+    SpendInput txI -> mkTxInLabel txI
+    CollateralInput txI -> mkTxInLabel txI
+
+mkTxInLabel :: C.TxIn -> DotCode
+mkTxInLabel txI = unqtDot ("txin_" <> replaceHash (C.renderTxIn txI))
+
+mkTxLabel :: C.TxId -> DotCode
+mkTxLabel txid = unqtDot ("tx_" <> filter (/= '"') (show txid))
+
+{-| Object that we display in the graph
+-}
+data FullTxObject =
+  FullTxBody C.TxId -- ^ Body of the transaction
+  | FullTxOutput C.TxIn -- ^ Transaction output
+  deriving stock (Eq, Ord, Show)
+
+instance GVT.PrintDot FullTxObject where
+  unqtDot = \case
+    FullTxBody txi   -> mkTxLabel txi
+    FullTxOutput txI -> mkTxInLabel txI
+
+dot' :: Text -> [ResolvedTx] -> DotGraph FullTxObject
+dot' (TL.fromStrict -> nm) transactions = GV.digraph (GV.Str nm) $ do
+  GV.graphAttrs [ A.RankDir A.FromLeft ]
+  GV.nodeAttrs
+    [ A.Shape A.Record
+    , A.style A.filled
+    , bgColor Colors.Gray93
+    , A.Height 0.1
+    ]
+  -- add all tx outs first
+  traverse_ (uncurry addTxOut) (Map.toList $ foldMap rtxInputs transactions <> foldMap (Map.fromList . fmap (second C.toCtxUTxOTxOut) . Utils.txnUtxos . rtxTransaction) transactions)
+  -- add transactions
+  -- add links
+  forM_ transactions $ \ftx ->
+    flip runReaderT ftx $ do
+      addTxBody (rtxTransaction ftx)
+      asks (Utils.spendInputs . txBodyContent) >>= traverse_ (addInput . SpendInput)
+      asks (Utils.referenceInputs . txBodyContent) >>= traverse_ (addInput . RefInput)
+      asks (Utils.collateralInputs . txBodyContent) >>= traverse_ (addInput . CollateralInput)
+      asks (Utils.txnUtxos . rtxTransaction) >>= traverse_ (uncurry addOutput)
+
+type GraphBuilder a = ReaderT ResolvedTx (GV.DotM FullTxObject) a
+
+addInput :: FullTxInput -> GraphBuilder ()
+addInput txI = do
+  i <- asks txId
+  lift $ do
+    let ref = FullTxOutput (getTxIn txI)
+        txt = case txI of
+                RefInput{}        -> "reference"
+                SpendInput{}      -> "spend"
+                CollateralInput{} -> "collateral"
+    GV.edge ref (FullTxBody i)
+      [ A.textLabel txt
+      ]
+
+addOutput :: C.TxIn -> C.TxOut context era -> GraphBuilder ()
+addOutput txI _ = do
+  i <- asks txId
+  lift $ do
+    let ref = FullTxOutput txI
+    GV.edge (FullTxBody i) ref []
+
+
+addTxBody :: C.Tx C.ConwayEra -> GraphBuilder ()
+addTxBody transaction = do
+  let i = C.getTxId $ C.getTxBody transaction
+      (C.Tx (C.TxBody content) _witnesses) = transaction
+      C.TxBodyContent{C.txWithdrawals=C.TxWithdrawals _ withdrawals} = content
+      Coin n = view L.txFee content
+  let labels =
+        [ A.FieldLabel "Transaction"
+        , A.FieldLabel $ "Fee: " <> TL.fromStrict (adaLabel n)
+        , A.FieldLabel $ TL.fromStrict $ C.serialiseToRawBytesHexText i
+        ] <> fmap withdrawalLabel withdrawals
+  lift $ GV.node (FullTxBody i) [A.Label $ A.RecordLabel labels]
+
+withdrawalLabel :: (C.StakeAddress, Coin, C.BuildTxWith C.ViewTx (C.Witness C.WitCtxStake C.ConwayEra)) -> A.RecordField
+withdrawalLabel (addr, Coin n, _) =
+  A.FieldLabel $ "Withdrawal: " <> TL.fromStrict (C.serialiseToBech32 addr) <> " (" <> TL.fromStrict (adaLabel n) <> ")"
+
+addTxOut :: (C.IsMaryBasedEra era) => C.TxIn -> C.TxOut ctx era -> GV.DotM FullTxObject ()
+addTxOut txI txOut = do
+  let ref = FullTxOutput txI
+  GV.node ref
+    [ A.Label $ A.RecordLabel (fullTxOutputLabel txI txOut)
+    , A.style A.rounded
+    ]

src/base/lib/Convex/Utils.hs

@@ -17,6 +17,13 @@ module Convex.Utils(
   scriptFromCborV1,
   unsafeScriptFromCborV1,
   scriptAddressV1,
+
+  -- * Transaction inputs
+  requiredTxIns,
+  spendInputs,
+  collateralInputs,
+  referenceInputs,
+
   -- * Serialised transactions
   txFromCbor,
   unsafeTxFromCbor,
@@ -66,12 +73,14 @@ import           Cardano.Ledger.Crypto                    (StandardCrypto)
 import           Cardano.Slotting.EpochInfo.API           (epochInfoSlotToUTCTime,
                                                            hoistEpochInfo)
 import qualified Cardano.Slotting.Time                    as Time
+import           Control.Lens                             (view)
 import           Control.Monad                            (void, when)
 import           Control.Monad.Except                     (MonadError)
 import           Control.Monad.IO.Class                   (MonadIO (..))
 import           Control.Monad.Result                     (ResultT, throwError)
 import qualified Control.Monad.Result                     as Result
 import           Control.Monad.Trans.Except               (ExceptT, runExceptT)
+import qualified Convex.CardanoApi.Lenses                 as L
 import           Convex.MonadLog                          (MonadLog, logWarnS)
 import           Convex.PlutusLedger.V1                   (transPOSIXTime,
                                                            unTransPOSIXTime)
@@ -302,3 +311,26 @@ alonzoEraUtxo f = case C.alonzoBasedEra @era of
   C.AlonzoEraOnwardsAlonzo  -> f
   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 =
+  spendInputs body
+  <> referenceInputs body
+  <> collateralInputs body