Add Cardano.Wallet.Read.Tx.TxOut

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:

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

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