Skip to content

Commit

Permalink
[ADP-3215] Add TxOut type to Cardano.Wallet.Read.Tx (#4698)
Browse files Browse the repository at this point in the history
This pull request adds a type `TxOut` to `Cardano.Wallet.Read.Tx.TxOut`.

The type `TxOut` occupies the following point in the design space:

* `TxOut` is era-*independent* — a value of this type can be any
transaction output from a past era.
* `TxOut` can — in principle — be deconstructed using functions from the
latest or next era. This is possible because transaction outputs are
upwards-compatible.
* `TxOut` can be serialized and deserialized to a format that is close
to the ledger CBOR. However, we allow `serialize . deserialize ≠ id` in
order to allow internal era upgrades.

The above design choices can be realized with different internal
representations. We choose the following:

*  `TxOut` is represented as a disjoint sum of `Output era`.
* `TxOut` supports explicit an upgrade to `Output era` where `era` is
the latest or next era — but this conversion is not zero-cost.

### Comments

* In addition to deconstruction, we also provide a constructor
`mkBasicTxOut` for convenience and testing.

### Issue Number

ADP-3215
  • Loading branch information
HeinrichApfelmus authored Aug 23, 2024
2 parents 99634cc + 933b15f commit 1c99602
Show file tree
Hide file tree
Showing 6 changed files with 836 additions and 11 deletions.
7 changes: 7 additions & 0 deletions lib/read/cardano-wallet-read.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -67,6 +67,7 @@ library
Cardano.Read.Ledger.Tx.Integrity
Cardano.Read.Ledger.Tx.Metadata
Cardano.Read.Ledger.Tx.Mint
Cardano.Read.Ledger.Tx.Output
Cardano.Read.Ledger.Tx.ReferenceInputs
Cardano.Read.Ledger.Tx.ScriptValidity
Cardano.Read.Ledger.Tx.Validity
Expand Down Expand Up @@ -103,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:
Expand Down Expand Up @@ -155,9 +157,11 @@ test-suite test
ghc-options: -with-rtsopts=-M2G -with-rtsopts=-N4
build-tool-depends: hspec-discover:hspec-discover
other-modules:
Cardano.Read.Ledger.OutputSpec
Cardano.Wallet.Read.EraValueSpec
Cardano.Wallet.Read.Tx.CBORSpec
Cardano.Wallet.Read.Tx.TxIdSpec
Cardano.Wallet.Read.Tx.TxOutSpec
Test.Unit.Cardano.Read.Ledger.Tx
Spec
SpecHook
Expand All @@ -168,6 +172,9 @@ test-suite test
build-depends:
, base
, bytestring
, cardano-ledger-api
, cardano-ledger-core
, cardano-ledger-mary
, cardano-wallet-read
, cardano-wallet-test-utils
, hspec
Expand Down
243 changes: 243 additions & 0 deletions lib/read/lib/Cardano/Read/Ledger/Tx/Output.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,243 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Copyright: © 2024 Cardano Foundation
License: Apache-2.0
Era-indexed transaction output.
-}
module Cardano.Read.Ledger.Tx.Output
( OutputType
, Output (..)
, getEraCompactAddr
, getEraValue
, upgradeToOutputBabbage
, upgradeToOutputConway
, deserializeOutput
, serializeOutput
)
where

import Prelude

import Cardano.Ledger.Alonzo.TxOut
( AlonzoTxOut
)
import Cardano.Ledger.Api
( Addr (AddrBootstrap)
, BootstrapAddress (..)
, eraProtVerLow
, mkBasicTxOut
, upgradeTxOut
)
import Cardano.Ledger.Babbage.TxOut
( BabbageTxOut
)
import Cardano.Ledger.Binary
( DecCBOR (decCBOR)
, DecoderError
, EncCBOR
, byronProtVer
, decodeFull
, decodeFullDecoder
, shelleyProtVer
)
import Cardano.Ledger.Core
( compactAddrTxOutL
, valueTxOutL
)
import Cardano.Ledger.Shelley.TxOut
( ShelleyTxOut
)
import Cardano.Read.Ledger.Address
( CompactAddr (..)
, CompactAddrType
)
import Cardano.Read.Ledger.Value
( Value (..)
, ValueType
, maryValueFromByronValue
)
import Cardano.Wallet.Read.Eras
( Allegra
, Alonzo
, Babbage
, Byron
, Conway
, Era (..)
, IsEra (..)
, Mary
, Shelley
)
import Control.Lens
( view
)
import Data.Text
( Text
)

import qualified Cardano.Chain.UTxO as BY
import qualified Cardano.Ledger.Binary.Encoding as Ledger
import qualified Data.ByteString.Lazy as BL

{-----------------------------------------------------------------------------
Output
------------------------------------------------------------------------------}

type family OutputType era where
OutputType Byron = BY.TxOut
OutputType Shelley = ShelleyTxOut Shelley
OutputType Allegra = ShelleyTxOut Allegra
OutputType Mary = ShelleyTxOut Mary
OutputType Alonzo = AlonzoTxOut Alonzo
OutputType Babbage = BabbageTxOut Babbage
OutputType Conway = BabbageTxOut Conway

newtype Output era = Output (OutputType era)

deriving instance Show (OutputType era) => Show (Output era)
deriving instance Eq (OutputType era) => Eq (Output era)

{-----------------------------------------------------------------------------
Eliminators
------------------------------------------------------------------------------}

{-# INLINEABLE getEraCompactAddr #-}
getEraCompactAddr :: forall era. IsEra era => Output era -> CompactAddr era
getEraCompactAddr = case theEra :: Era era of
Byron -> address $ (\(BY.CompactTxOut a _) -> a) . BY.toCompactTxOut
Shelley -> address (view compactAddrTxOutL)
Allegra -> address (view compactAddrTxOutL)
Mary -> address (view compactAddrTxOutL)
Alonzo -> address (view compactAddrTxOutL)
Babbage -> address (view compactAddrTxOutL)
Conway -> address (view compactAddrTxOutL)

-- Helper function for type inference
address
:: (OutputType era -> CompactAddrType era)
-> Output era -> CompactAddr era
address f (Output x) = CompactAddr (f x)

{-# INLINEABLE getEraValue #-}
getEraValue :: forall era. IsEra era => Output era -> Value era
getEraValue = case theEra :: Era era of
Byron -> value BY.txOutValue
Shelley -> value (view valueTxOutL)
Allegra -> value (view valueTxOutL)
Mary -> value (view valueTxOutL)
Alonzo -> value (view valueTxOutL)
Babbage -> value (view valueTxOutL)
Conway -> value (view valueTxOutL)

-- Helper function for type inference
value :: (OutputType era -> ValueType era) -> Output era -> Value era
value f (Output x) = Value (f x)

{-----------------------------------------------------------------------------
Operations
------------------------------------------------------------------------------}

{-# INLINEABLE upgradeToOutputBabbage #-}
-- | Upgrade an 'Output' to the 'Babbage' era if possibile.
--
-- Hardfork: Update this function to the new era.
upgradeToOutputBabbage
:: forall era. IsEra era
=> Output era -> Maybe (Output Babbage)
upgradeToOutputBabbage = case theEra :: Era era of
Byron -> Just . onOutput
(\(BY.TxOut addr lovelace) ->
mkBasicTxOut
(AddrBootstrap (BootstrapAddress addr))
(maryValueFromByronValue lovelace)
)
Shelley -> Just . onOutput
(upgradeTxOut . upgradeTxOut . upgradeTxOut . upgradeTxOut)
Allegra -> Just . onOutput
(upgradeTxOut . upgradeTxOut . upgradeTxOut)
Mary -> Just . onOutput
(upgradeTxOut . upgradeTxOut)
Alonzo -> Just . onOutput upgradeTxOut
Babbage -> Just . id
Conway -> const Nothing

{-# INLINEABLE upgradeToOutputConway #-}
-- | Upgrade an 'Output' to the 'Conway' era.
--
-- Hardfork: Update this function to the next era.
upgradeToOutputConway :: forall era. IsEra era => Output era -> Output Conway
upgradeToOutputConway = case theEra :: Era era of
Byron -> onOutput
$ \(BY.TxOut addr lovelace) ->
mkBasicTxOut
(AddrBootstrap (BootstrapAddress addr))
(maryValueFromByronValue lovelace)
Shelley -> onOutput
$ upgradeTxOut . upgradeTxOut . upgradeTxOut . upgradeTxOut
. upgradeTxOut
Allegra -> onOutput
$ upgradeTxOut . upgradeTxOut . upgradeTxOut . upgradeTxOut
Mary -> onOutput
$ upgradeTxOut . upgradeTxOut . upgradeTxOut
Alonzo -> onOutput
$ upgradeTxOut . upgradeTxOut
Babbage -> onOutput upgradeTxOut
Conway -> id

-- Helper function for type inference
onOutput
:: (OutputType era1 -> OutputType era2)
-> Output era1 -> Output era2
onOutput f (Output x) = Output (f x)

{-----------------------------------------------------------------------------
Serialization
------------------------------------------------------------------------------}

{-# INLINABLE serializeOutput #-}
-- | Serialize an 'Output' in binary format, e.g. for storing in a database.
serializeOutput :: forall era. IsEra era => Output era -> BL.ByteString
serializeOutput = case theEra :: Era era of
Byron -> encode byronProtVer
Shelley -> encode (eraProtVerLow @Shelley)
Allegra -> encode (eraProtVerLow @Allegra)
Mary -> encode (eraProtVerLow @Mary)
Alonzo -> encode (eraProtVerLow @Alonzo)
Babbage -> encode (eraProtVerLow @Babbage)
Conway -> encode (eraProtVerLow @Conway)
where
encode
:: EncCBOR (OutputType era)
=> Ledger.Version -> Output era -> BL.ByteString
encode protVer (Output out) = Ledger.serialize protVer out

{-# INLINABLE deserializeOutput #-}
-- | Deserialize an 'Output' from the binary format.
--
-- prop> ∀ o. deserializeOutput (serializeOutput o) == Just o
deserializeOutput
:: forall era . IsEra era
=> BL.ByteString -> Either DecoderError (Output era)
deserializeOutput = case theEra :: Era era of
Byron -> fmap Output . decodeFull byronProtVer
Shelley -> decode shelleyProtVer "ShelleyTxOut"
Allegra -> decode (eraProtVerLow @Allegra) "AllegraTxOut"
Mary -> decode (eraProtVerLow @Mary) "MaryTxOut"
Alonzo -> decode (eraProtVerLow @Alonzo) "AlonzoTxOut"
Babbage -> decode (eraProtVerLow @Babbage) "BabbageTxOut"
Conway -> decode (eraProtVerLow @Conway) "ConwayTxOut"
where
decode
:: DecCBOR (OutputType era)
=> Ledger.Version
-> Text
-> BL.ByteString
-> Either DecoderError (Output era)
decode protVer label =
fmap Output . decodeFullDecoder protVer label decCBOR
Loading

0 comments on commit 1c99602

Please sign in to comment.