Drop support balancing in future eras

lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs

@@ -155,10 +155,6 @@ import Cardano.Api
     , toNetworkMagic
     , unNetworkMagic
     )
-import Cardano.Api.Extra
-    ( inAnyCardanoEra )
-import Cardano.Api.Shelley
-    ( ShelleyLedgerEra )
 import Cardano.BM.Tracing
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Mnemonic
@@ -509,7 +505,7 @@ import Cardano.Wallet.Primitive.Types.Tx
     , TxChange (..)
     , TxStatus (..)
     , UnsignedTx (..)
-    , cardanoTxIdeallyNoLaterThan
+    , cardanoTxInExactEra
     , getSealedTxWitnesses
     , sealedTxFromCardanoBody
     )
@@ -550,16 +546,14 @@ import Cardano.Wallet.Unsafe
     ( unsafeRunExceptT )
 import Cardano.Wallet.Write.Tx
     ( AnyRecentEra (..) )
-import Cardano.Wallet.Write.Tx.Balance
-    ( constructUTxOIndex )
 import Control.Arrow
     ( second, (&&&) )
 import Control.DeepSeq
     ( NFData )
 import Control.Error.Util
     ( failWith )
 import Control.Monad
-    ( forM, forever, join, void, when, (<=<), (>=>) )
+    ( forM, forever, join, void, when, (>=>) )
 import Control.Monad.Error.Class
     ( throwError )
 import Control.Monad.IO.Class
@@ -3074,82 +3068,39 @@ balanceTransaction
     mScriptTemplate
     (ApiT wid)
     body = do
-    -- NOTE: Ideally we'd read @pp@ and @era@ atomically.
-    pp <- liftIO $ NW.currentProtocolParameters nl
-    era <- liftIO $ NW.currentNodeEra nl
+    timeTranslation <- liftIO $ toTimeTranslation (timeInterpreter netLayer)
+    era <- liftIO $ NW.currentNodeEra netLayer
+
+    Write.AnyRecentEra recentEra <- guardIsRecentEra era
+    pp <- liftIO (currentProtocolParameters netLayer)
+
     withWorkerCtx ctx wid liftE liftE $ \wrk -> do
-        (walletUTxO, wallet, _txs) <- handler $ W.readWalletUTxO @_ @s wrk
-        timeTranslation <- liftIO $ toTimeTranslation (timeInterpreter netLayer)
-        let mkPartialTx
-                :: forall era. Write.IsRecentEra era => Cardano.Tx era
-                -> Handler (Write.PartialTx era)
-            mkPartialTx tx = do
-                utxo <- fmap Write.toCardanoUTxO $ mkLedgerUTxO $ body ^. #inputs
-                pure $ Write.PartialTx
-                    tx
-                    utxo
-                    (fromApiRedeemer <$> body ^. #redeemers)
-              where
-                -- NOTE: There are a couple of spread-out pieces of logic
-                -- dealing with the choice of era, most prominantly: tx, utxo,
-                -- pparams / current node era. It /might/ be neater to have a
-                -- single function dedicated to this choice instead; something
-                -- like
-                -- @@
-                --      chooseEra
-                --          :: InRecentEra Tx
-                --          -> InRecentEra UTxO
-                --          -> InRecentEra PParams
-                --          -> (IsRecentEra era
-                --              => Tx era
-                --              -> UTxO era
-                --              -> PParams era
-                --              -> res)
-                --          -> res
-                -- @@
-
-                mkRecentEra :: Handler (Write.RecentEra era)
-                mkRecentEra = case Cardano.cardanoEra @era of
-                    Cardano.ConwayEra -> pure Write.RecentEraConway
-                    Cardano.BabbageEra -> pure Write.RecentEraBabbage
-                    _ -> liftHandler $ throwE $ W.ErrOldEraNotSupported era
-
-                mkLedgerUTxO
-                    :: [ApiExternalInput n]
-                    -> Handler (Write.UTxO (ShelleyLedgerEra era))
-                mkLedgerUTxO ins = do
-                    recentEra <- mkRecentEra
-                    pure
-                        . Write.utxoFromTxOutsInRecentEra recentEra
-                        . map fromExternalInput
-                        $ ins
+        (utxo, wallet, _txs) <-
+            liftIO $ W.readWalletUTxO wrk
+
+        partialTx <- parsePartialTx recentEra
 
         let balanceTx
                 :: forall era. Write.IsRecentEra era
                 => Write.PartialTx era
                 -> Handler (Cardano.Tx era)
-            balanceTx partialTx =
+            balanceTx ptx =
                 liftHandler $ fst <$> Write.balanceTransaction @_ @IO @s
                     (MsgWallet . W.MsgBalanceTx >$< wrk ^. W.logger)
                     (Write.UTxOAssumptions
                         txLayer
                         genInpScripts
                         mScriptTemplate
-                        (txWitnessTagFor @k))
-                    (Write.unsafeFromWalletProtocolParameters pp)
+                        (txWitnessTagFor @k)
+                        )
+                    (Write.unsafeFromWalletProtocolParameters @era pp)
                     timeTranslation
-                    (constructUTxOIndex walletUTxO)
+                    (Write.constructUTxOIndex utxo)
                     (W.defaultChangeAddressGen argGenChange (Proxy @k))
                     (getState wallet)
-                    partialTx
-
-        anyRecentTx <- maybeToHandler (W.ErrOldEraNotSupported era)
-            . Write.asAnyRecentEra
-            . cardanoTxIdeallyNoLaterThan era
-            . getApiT $ body ^. #transaction
+                    ptx
 
-        res <- Write.withInAnyRecentEra anyRecentTx
-            (fmap inAnyCardanoEra . balanceTx <=< mkPartialTx)
+        res <- Cardano.InAnyCardanoEra Write.cardanoEra <$> balanceTx partialTx
 
         case body ^. #encoding of
             Just HexEncoded ->
@@ -3158,11 +3109,25 @@ balanceTransaction
             _ -> pure $ ApiSerialisedTransaction
                 (ApiT $ W.sealedTxFromCardano res) Base64Encoded
   where
-    nl = ctx ^. networkLayer
-
-    maybeToHandler :: IsServerError e => e -> Maybe a -> Handler a
-    maybeToHandler _ (Just a) = pure a
-    maybeToHandler e Nothing  = liftHandler $ throwE e
+    parsePartialTx
+        :: Write.IsRecentEra era
+        => Write.RecentEra era
+        -> Handler (Write.PartialTx era)
+    parsePartialTx era = do
+        let externalUTxO = Write.toCardanoUTxO
+                $ Write.utxoFromTxOutsInRecentEra era
+                $ map fromExternalInput
+                $ body ^. #inputs
+
+        tx <- maybe (liftHandler $ throwE $ W.ErrTxNotInEra $ AnyRecentEra era) pure
+            . cardanoTxInExactEra (Write.cardanoEraFromRecentEra era)
+            . getApiT
+            $ body ^. #transaction
+
+        return $ Write.PartialTx
+            tx
+            externalUTxO
+            (fromApiRedeemer <$> body ^. #redeemers)
 
 decodeTransaction
     :: forall s n

lib/wallet/src/Cardano/Wallet/Primitive/Types/Tx.hs

@@ -34,6 +34,7 @@ module Cardano.Wallet.Primitive.Types.Tx
     -- * Serialisation
     , SealedTx (serialisedTx)
     , cardanoTxIdeallyNoLaterThan
+    , cardanoTxInExactEra
     , sealedTxFromBytes
     , sealedTxFromBytes'
     , sealedTxFromCardano
@@ -94,6 +95,7 @@ import Cardano.Wallet.Primitive.Types.Tx.SealedTx
     , SerialisedTx (..)
     , SerialisedTxParts (..)
     , cardanoTxIdeallyNoLaterThan
+    , cardanoTxInExactEra
     , getSealedTxBody
     , getSealedTxWitnesses
     , getSerialisedTxParts

lib/wallet/src/Cardano/Wallet/Write/Tx.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE ExplicitNamespaces #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -201,7 +201,7 @@ import Data.IntCast
 import Data.Maybe
     ( fromMaybe, isJust )
 import Data.Type.Equality
-    ( TestEquality (testEquality), type (:~:) (Refl) )
+    ( (:~:) (Refl), TestEquality (testEquality) )
 import Data.Typeable
     ( Typeable )
 import Numeric.Natural