Convert UTxO from supported eras to BabbageEra

This works as long as all shelley based eras use the 'MaryValue era'
type from the cardano-ledger.

Author: ch1bo

hydra-cardano-api/src/Cardano/Api/UTxO.hs

@@ -11,6 +11,9 @@ module Cardano.Api.UTxO where
 import Cardano.Api hiding (UTxO, toLedgerUTxO)
 import Cardano.Api qualified
 import Cardano.Api.Shelley (ReferenceScript (..))
+import Cardano.Api.Value (lovelaceToCoin)
+import Cardano.Ledger.Babbage ()
+import Cardano.Ledger.Mary.Value (MaryValue (..))
 import Data.Bifunctor (second)
 import Data.Coerce (coerce)
 import Data.List qualified as List
@@ -87,35 +90,38 @@ min = UTxO . uncurry Map.singleton . Map.findMin . toMap
 -- * Type Conversions
 
 -- | Transforms a UTxO containing tx outs from any era into Babbage era.
-fromApi :: forall era. ShelleyBasedEra era -> Cardano.Api.UTxO era -> UTxO
-fromApi sbe (Cardano.Api.UTxO eraUTxO) =
-  let eraPairs = Map.toList eraUTxO
-      babbagePairs = second (coerceOutputToEra sbe) <$> eraPairs
-   in fromPairs babbagePairs
-
-coerceOutputToEra :: forall era. ShelleyBasedEra era -> TxOut CtxUTxO era -> TxOut CtxUTxO Era
-coerceOutputToEra sbe (TxOut eraAddress eraValue eraDatum eraRefScript) =
-  TxOut
-    (coerceAddressToEra eraAddress)
-    (coerceValueToEra sbe eraValue)
-    (coerceDatumToEra eraDatum)
-    (coerceRefScriptToEra eraRefScript)
-
-coerceAddressToEra :: AddressInEra era -> AddressInEra Era
-coerceAddressToEra (AddressInEra _ eraAddress) = anyAddressInShelleyBasedEra ShelleyBasedEraBabbage (toAddressAny eraAddress)
-
-coerceValueToEra :: forall era. ShelleyBasedEra era -> TxOutValue era -> TxOutValue Era
-coerceValueToEra _ (TxOutValueByron eraLovelace) = lovelaceToTxOutValue shelleyBasedEra eraLovelace
-coerceValueToEra sbe (TxOutValueShelleyBased _ value) = TxOutValueShelleyBased ShelleyBasedEraBabbage (toLedgerValue MaryEraOnwardsBabbage $ fromLedgerValue sbe value)
-
-coerceDatumToEra :: TxOutDatum CtxUTxO era -> TxOutDatum CtxUTxO Era
-coerceDatumToEra TxOutDatumNone = TxOutDatumNone
-coerceDatumToEra (TxOutDatumHash _ hashScriptData) = TxOutDatumHash AlonzoEraOnwardsBabbage hashScriptData
-coerceDatumToEra (TxOutDatumInline _ hashableScriptData) = TxOutDatumInline BabbageEraOnwardsBabbage hashableScriptData
-
-coerceRefScriptToEra :: ReferenceScript era -> ReferenceScript Era
-coerceRefScriptToEra ReferenceScriptNone = ReferenceScriptNone
-coerceRefScriptToEra (ReferenceScript _ scriptInAnyLang) = ReferenceScript BabbageEraOnwardsBabbage scriptInAnyLang
+fromApi :: Cardano.Api.UTxO era -> UTxO
+fromApi (Cardano.Api.UTxO eraUTxO) =
+  fromPairs $ second convertOutputToEra <$> Map.toList eraUTxO
+ where
+  -- NOTE: At latest the TxOutValue is an existential where we need to case on
+  -- the 'sbe' witness to get constraints on the contained 'value', but the
+  -- 'cardano-api' does that already when allowing conversion of their
+  -- (complicated) constrained types to the cardano-ledger types - so we just
+  -- convert forth and back.
+  convertOutputToEra :: TxOut CtxUTxO era -> TxOut CtxUTxO Era
+  convertOutputToEra (TxOut eraAddress eraValue eraDatum eraRefScript) =
+    TxOut
+      (convertAddressToEra eraAddress)
+      (convertValueToEra eraValue)
+      (convertDatumToEra eraDatum)
+      (convertRefScriptToEra eraRefScript)
+
+  convertAddressToEra :: AddressInEra era -> AddressInEra Era
+  convertAddressToEra (AddressInEra _ eraAddress) = anyAddressInShelleyBasedEra ShelleyBasedEraBabbage (toAddressAny eraAddress)
+
+  convertValueToEra :: TxOutValue era -> TxOutValue Era
+  convertValueToEra (TxOutValueByron lovelace) = lovelaceToTxOutValue lovelace
+  convertValueToEra (TxOutValueShelleyBased sbe value) = TxOutValueShelleyBased shelleyBasedEra (toLedgerValue MaryEraOnwardsBabbage $ fromLedgerValue sbe value)
+
+  convertDatumToEra :: TxOutDatum CtxUTxO era -> TxOutDatum CtxUTxO Era
+  convertDatumToEra TxOutDatumNone = TxOutDatumNone
+  convertDatumToEra (TxOutDatumHash _ hashScriptData) = TxOutDatumHash AlonzoEraOnwardsBabbage hashScriptData
+  convertDatumToEra (TxOutDatumInline _ hashableScriptData) = TxOutDatumInline BabbageEraOnwardsBabbage hashableScriptData
+
+  convertRefScriptToEra :: ReferenceScript era -> ReferenceScript Era
+  convertRefScriptToEra ReferenceScriptNone = ReferenceScriptNone
+  convertRefScriptToEra (ReferenceScript _ scriptInAnyLang) = ReferenceScript BabbageEraOnwardsBabbage scriptInAnyLang
 
 toApi :: UTxO -> Cardano.Api.UTxO Era
 toApi = coerce

hydra-node/src/Hydra/Chain/CardanoClient.hs

@@ -321,7 +321,7 @@ queryUTxO networkId socket queryPoint addresses =
 queryUTxOExpr :: ShelleyBasedEra era -> [Address ShelleyAddr] -> LocalStateQueryExpr b p QueryInMode r IO UTxO
 queryUTxOExpr sbe addresses = do
   eraUTxO <- queryInShelleyBasedEraExpr sbe $ QueryUTxO (QueryUTxOByAddress (Set.fromList $ map AddressShelley addresses))
-  pure $ UTxO.fromApi sbe eraUTxO
+  pure $ UTxO.fromApi eraUTxO
 
 -- | Query UTxO for given tx inputs at given point.
 --
@@ -339,7 +339,7 @@ queryUTxOByTxIn networkId socket queryPoint inputs =
     (AnyCardanoEra era) <- queryCurrentEraExpr
     (sbe :: ShelleyBasedEra e) <- liftIO $ assumeShelleyBasedEraOrThrow era
     eraUTxO <- queryInShelleyBasedEraExpr sbe $ QueryUTxO (QueryUTxOByTxIn (Set.fromList inputs))
-    pure $ UTxO.fromApi sbe eraUTxO
+    pure $ UTxO.fromApi eraUTxO
 
 assumeShelleyBasedEraOrThrow :: MonadThrow m => CardanoEra era -> m (ShelleyBasedEra era)
 assumeShelleyBasedEraOrThrow era = do
@@ -360,7 +360,7 @@ queryUTxOWhole ::
   QueryPoint ->
   IO UTxO
 queryUTxOWhole networkId socket queryPoint = do
-  UTxO.fromApi ShelleyBasedEraBabbage <$> (runQuery networkId socket queryPoint query >>= throwOnEraMismatch)
+  UTxO.fromApi <$> (runQuery networkId socket queryPoint query >>= throwOnEraMismatch)
  where
   query =
     QueryInEra