From bd7f6655e9bb9a3098c6bf8a26d28ef6190560cf Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Thu, 25 Jul 2024 16:14:22 +0200 Subject: [PATCH] Add `Cardano.Wallet.Read.Tx.TxOut` --- lib/read/cardano-wallet-read.cabal | 1 + lib/read/lib/Cardano/Wallet/Read/Tx/TxOut.hs | 281 +++++++++++++++++++ lib/read/lib/Cardano/Wallet/Read/Value.hs | 43 ++- 3 files changed, 316 insertions(+), 9 deletions(-) create mode 100644 lib/read/lib/Cardano/Wallet/Read/Tx/TxOut.hs diff --git a/lib/read/cardano-wallet-read.cabal b/lib/read/cardano-wallet-read.cabal index 391c8aa683c..1e8de8d1ea9 100644 --- a/lib/read/cardano-wallet-read.cabal +++ b/lib/read/cardano-wallet-read.cabal @@ -104,6 +104,7 @@ library Cardano.Wallet.Read.Tx.ScriptValidity Cardano.Wallet.Read.Tx.TxId Cardano.Wallet.Read.Tx.TxIn + Cardano.Wallet.Read.Tx.TxOut Cardano.Wallet.Read.Value build-depends: diff --git a/lib/read/lib/Cardano/Wallet/Read/Tx/TxOut.hs b/lib/read/lib/Cardano/Wallet/Read/Tx/TxOut.hs new file mode 100644 index 00000000000..2827a2950b0 --- /dev/null +++ b/lib/read/lib/Cardano/Wallet/Read/Tx/TxOut.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- | +Copyright: © 2024 Cardano Foundation +License: Apache-2.0 + +'TxOut' — transaction output. +-} +module Cardano.Wallet.Read.Tx.TxOut + ( -- * TxOut + TxOut + , mkBasicTxOut + , getCompactAddr + , getValue + , utxoFromEraTx + , upgradeTxOutToConway + + -- * Serialization + , deserializeTxOut + , serializeTxOut + ) + where + +import Prelude + +import Cardano.Ledger.Binary + ( DecoderError (DecoderErrorCustom) + ) +import Cardano.Ledger.Compactible + ( toCompact + ) +import Cardano.Read.Ledger.Tx.CollateralOutputs + ( CollateralOutputs (..) + , getEraCollateralOutputs + ) +import Cardano.Read.Ledger.Tx.Output + ( Output (..) + , OutputType + , deserializeOutput + , getEraCompactAddr + , getEraValue + , serializeOutput + , upgradeOutputToConway + ) +import Cardano.Read.Ledger.Tx.Outputs + ( Outputs (..) + , getEraOutputs + ) +import Cardano.Wallet.Read.Address + ( CompactAddr + , fromEraCompactAddr + ) +import Cardano.Wallet.Read.Eras + ( Conway + , Era (..) + , EraValue (..) + , IsEra (theEra) + , indexOfEra + , parseEraIndex + ) +import Cardano.Wallet.Read.Tx + ( Tx (..) + ) +import Cardano.Wallet.Read.Tx.TxIn + ( TxIn + , pattern TxIn + , pattern TxIx + ) +import Cardano.Wallet.Read.Value + ( Value + , fromEraValue + , toMaryValue + ) +import Data.Foldable + ( toList + ) +import Data.Maybe + ( fromMaybe + ) +import Data.Maybe.Strict + ( StrictMaybe (SNothing) + ) +import Data.Word + ( Word16 + ) + +import qualified Cardano.Ledger.Babbage.TxBody as Babbage +import qualified Cardano.Wallet.Read.Tx.ScriptValidity as Read +import qualified Cardano.Wallet.Read.Tx.TxId as Read +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + +{----------------------------------------------------------------------------- + Type +------------------------------------------------------------------------------} +-- | A 'TxOut' is a transaction output from any era — past, present +-- or next one. +newtype TxOut = TxOutC (EraValue Output) + +-- | Test whether two 'TxOut' are equal, +-- in a way that is independent +-- of the particular era-dependent internal representation. +instance Eq TxOut where + {-# INLINABLE (==) #-} + (TxOutC x) == (TxOutC y) = eqTxOut x y + +-- | Make a basic 'TxOut' from an address and a value. +mkBasicTxOut :: CompactAddr -> Value -> TxOut +mkBasicTxOut addr value = + TxOutC (EraValue (Output txout :: Output Conway)) + where + val = toMaryValue value + -- Cardano.Ledger uses the same error message when converting + cVal = fromMaybe (error ("Illegal Value in TxOut: " ++ show val)) + $ toCompact val + txout = Babbage.TxOutCompact addr cVal + +{-# INLINEABLE getCompactAddr #-} +-- | Get the address which controls who can spend the transaction output. +getCompactAddr :: TxOut -> CompactAddr +getCompactAddr (TxOutC (EraValue txout)) = + fromEraCompactAddr $ getEraCompactAddr txout + +{-# INLINEABLE getValue #-} +-- | Get the monetary 'Value' in this transaction output. +getValue :: TxOut -> Value +getValue (TxOutC (EraValue txout)) = + fromEraValue $ getEraValue txout + +-- | Upgrade the internal representation of a 'TxOut' to the 'Conway' era. +upgradeTxOutToConway :: TxOut -> TxOut +upgradeTxOutToConway (TxOutC (EraValue txout)) = + TxOutC (EraValue (upgradeOutputToConway txout)) + +-- Test for equality. +eqTxOut :: EraValue Output -> EraValue Output -> Bool +eqTxOut (EraValue (v :: Output erax)) (EraValue (w :: Output eray)) = + case (theEra :: Era erax, theEra :: Era eray) of + (Byron, Byron) -> v == w + (Shelley, Shelley) -> v == w + (Allegra, Allegra) -> v == w + (Mary, Mary) -> v == w + (Alonzo, Alonzo) -> v == w + (Babbage, Babbage) -> v == w + (Conway, Conway) -> v == w + (_, _) -> upgradeOutputToConway v == upgradeOutputToConway w + +{----------------------------------------------------------------------------- + Serialization +------------------------------------------------------------------------------} + +-- | Serialize a 'TxOut' in binary format, e.g. for storing in a database. +serializeTxOut :: TxOut -> BL.ByteString +serializeTxOut (TxOutC (EraValue (txout :: Output era))) = + BL.cons tag (serializeOutput txout) + where + tag = toEnum (indexOfEra (theEra :: Era era)) + +type Dec era = Either DecoderError (Output era) + +-- | Deserialize a 'TxOut' from the binary format. +-- +-- prop> ∀ o. deserializeTxOut (serializeTxOut o) == Just o +deserializeTxOut :: BL.ByteString -> Either DecoderError TxOut +deserializeTxOut bytes + | Just (x,xs) <- BL.uncons bytes = do + eera <- maybe (Left $ errUnknownEraIndex x) Right + $ parseEraIndex (fromEnum x) + case eera of + EraValue (_ :: Era era) -> + TxOutC . EraValue <$> (deserializeOutput xs :: Dec era) + | otherwise = + Left $ DecoderErrorCustom "Empty input" "" + where + errUnknownEraIndex = + DecoderErrorCustom "Unknown era index" . T.pack . show + +{----------------------------------------------------------------------------- + Transactions +------------------------------------------------------------------------------} + +{-# INLINEABLE utxoFromEraTx #-} +-- | Unspent transaction outputs (UTxO) created by the transaction. +utxoFromEraTx :: forall era. IsEra era => Tx era -> Map.Map TxIn TxOut +utxoFromEraTx tx = + case Read.getScriptValidity tx of + Read.IsValid True -> utxoFromEraTxCollateralOutputs tx + Read.IsValid False -> utxoFromEraTxOutputs tx + +{-# INLINEABLE utxoFromEraTxOutputs #-} +-- | UTxO corresponding to the ordinary outputs of a transaction. +-- +-- This function ignores the transaction's script validity. +-- +utxoFromEraTxOutputs + :: forall era. IsEra era => Tx era -> Map.Map TxIn TxOut +utxoFromEraTxOutputs tx = + withFoldableOutputs toMap (getEraOutputs tx) + where + txid = Read.getTxId tx + mkOutputInEra out = Output out :: Output era + + toMap + :: forall t. Foldable t + => t (OutputType era) -> Map.Map TxIn TxOut + toMap = + Map.fromList + . zipWith (\ix -> mkTxInTxOutPair txid ix . mkOutputInEra) [0..] + . toList + +{-# INLINEABLE utxoFromEraTxCollateralOutputs #-} +-- | UTxO corresponding to the collateral outputs of a transaction. +-- +-- This function ignores the transaction's script validity. +-- +utxoFromEraTxCollateralOutputs + :: forall era. IsEra era => Tx era -> Map.Map TxIn TxOut +utxoFromEraTxCollateralOutputs tx = + withMaybeCollateralOutputs singleton (getEraCollateralOutputs tx) + where + txid = Read.getTxId tx + mkOutputInEra out = Output out :: Output era + + singleton :: StrictMaybe (OutputType era) -> Map.Map TxIn TxOut + singleton = + Map.fromList + . map (mkTxInTxOutPair txid index . mkOutputInEra) + . toList + + -- To reference a collateral output within transaction t, we specify an + -- output index that is equal to the number of ordinary outputs within t. + -- + -- See definition of function "collOuts" within "Formal Specification of + -- the Cardano Ledger for the Babbage era". + -- + -- https://github.com/IntersectMBO/cardano-ledger?tab=readme-ov-file + -- + index :: Word16 + index = fromIntegral $ + withFoldableOutputs length (getEraOutputs tx) + +-- Helper function: Create a pair @(TxIn, TxOut)@. +mkTxInTxOutPair + :: forall era. IsEra era + => Read.TxId -> Word16 -> Output era -> (TxIn, TxOut) +mkTxInTxOutPair txid ix out = + ( TxIn txid (TxIx ix) + , TxOutC (EraValue out) + ) + +-- Helper function: Treat the 'Outputs' as a 'Foldable' container. +withFoldableOutputs + :: forall era a. IsEra era + => (forall t. Foldable t => t (OutputType era) -> a) + -> Outputs era -> a +withFoldableOutputs f = case theEra :: Era era of + Byron -> \(Outputs x) -> f x + Shelley -> \(Outputs x) -> f x + Allegra -> \(Outputs x) -> f x + Mary -> \(Outputs x) -> f x + Alonzo -> \(Outputs x) -> f x + Babbage -> \(Outputs x) -> f x + Conway -> \(Outputs x) -> f x + +-- Helper function: Treat the 'CollateralOutputs' as a 'StrictMaybe'. +withMaybeCollateralOutputs + :: forall era a. IsEra era + => (StrictMaybe (OutputType era) -> a) + -> CollateralOutputs era -> a +withMaybeCollateralOutputs f = case theEra :: Era era of + Byron -> \(CollateralOutputs _) -> f SNothing + Shelley -> \(CollateralOutputs _) -> f SNothing + Allegra -> \(CollateralOutputs _) -> f SNothing + Mary -> \(CollateralOutputs _) -> f SNothing + Alonzo -> \(CollateralOutputs _) -> f SNothing + Babbage -> \(CollateralOutputs x) -> f x + Conway -> \(CollateralOutputs x) -> f x diff --git a/lib/read/lib/Cardano/Wallet/Read/Value.hs b/lib/read/lib/Cardano/Wallet/Read/Value.hs index 406a8d3d2a4..2b5e66983db 100644 --- a/lib/read/lib/Cardano/Wallet/Read/Value.hs +++ b/lib/read/lib/Cardano/Wallet/Read/Value.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {- | @@ -29,7 +31,7 @@ module Cardano.Wallet.Read.Value , lessOrEqual -- * Internal - , fromMaryValue + , fromEraValue , toMaryValue ) where @@ -47,9 +49,14 @@ import Cardano.Ledger.Val ( pointwise , (<->) ) +import Cardano.Read.Ledger.Eras + ( Era (..) + , IsEra (..) + ) import qualified Cardano.Ledger.BaseTypes as SH import qualified Cardano.Ledger.Mary.Value as MA +import qualified Cardano.Read.Ledger.Value as L {----------------------------------------------------------------------------- MultiAssets @@ -77,14 +84,6 @@ type MultiAsset = MA.MultiAsset StandardCrypto -- | Monetary values, representing both ADA and native assets/tokens. newtype Value = Value (MA.MaryValue StandardCrypto) --- | Internal: Convert from ledger 'MaryValue'. -fromMaryValue :: MA.MaryValue StandardCrypto -> Value -fromMaryValue = Value - --- | Internal: Convert to ledger 'MaryValue'. -toMaryValue :: Value -> MA.MaryValue StandardCrypto -toMaryValue (Value v) = v - instance Eq Value where (Value x) == (Value y) = x == y @@ -137,3 +136,29 @@ subtract (Value x) (Value y) = Value (x <-> y) lessOrEqual :: Value -> Value -> Bool lessOrEqual (Value value1) (Value value2) = pointwise (<=) value1 value2 + +{----------------------------------------------------------------------------- + Conversions from Eras +------------------------------------------------------------------------------} +-- | Internal: Convert from ledger 'MaryValue'. +fromMaryValue :: MA.MaryValue StandardCrypto -> Value +fromMaryValue = Value + +-- | Internal: Convert to ledger 'MaryValue'. +toMaryValue :: Value -> MA.MaryValue StandardCrypto +toMaryValue (Value v) = v + +-- | Internal: Convert from era-indexed 'L.Value'. +fromEraValue :: forall era. IsEra era => L.Value era -> Value +fromEraValue = fromMaryValue . case theEra :: Era era of + Byron -> onValue L.maryValueFromByronValue + Shelley -> onValue L.maryValueFromShelleyValue + Allegra -> onValue L.maryValueFromShelleyValue + Mary -> onValue id + Alonzo -> onValue id + Babbage -> onValue id + Conway -> onValue id + +-- Helper function for type inference. +onValue :: (L.ValueType era -> t) -> L.Value era -> t +onValue f (L.Value x) = f x