Automatically (try to) upgrade transaction on submission.

CardanoSolutions · Sep 13, 2024 · 5f3c819 · 5f3c819
1 parent 09f217d
commit 5f3c819
Show file tree

Hide file tree

Showing 4 changed files with 108 additions and 11 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -7,6 +7,20 @@ pre: "<b>6. </b>"
 math: true
 ---
 
+### [6.7.0] - 2024-09-13
+
+#### Added
+
+- Automatically upgrade transactions from previous era (up until Alonzo) on submission.
+
+#### Changed
+
+- N/A
+
+#### Removed
+
+- N/A
+
 ### [6.6.2] - 2024-09-10
 
 #### Added

diff --git a/server/src/Ogmios/App/Protocol/TxSubmission.hs b/server/src/Ogmios/App/Protocol/TxSubmission.hs
@@ -53,6 +53,7 @@ import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Core
     ( EraTx (..)
     , EraTxBody (..)
+    , eraName
     )
 import Control.Monad.Trans.Except
     ( Except
@@ -85,8 +86,10 @@ import Ogmios.Control.MonadSTM
     , takeTMVar
     )
 import Ogmios.Data.EraTranslation
-    ( MultiEraUTxO (..)
+    ( MostRecentEra
+    , MultiEraUTxO (..)
     , Upgrade (..)
+    , upgradeGenTx
     )
 import Ogmios.Data.Json
     ( Json
@@ -128,10 +131,14 @@ import Ouroboros.Consensus.Cardano.Block
     , CardanoBlock
     , CardanoQueryResult
     , GenTx (..)
+    , HardForkApplyTxErr (..)
     )
 import Ouroboros.Consensus.HardFork.Combinator
     ( HardForkBlock
     )
+import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
+    ( EraMismatch (..)
+    )
 import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query
     ( QueryHardFork (..)
     )
@@ -180,6 +187,7 @@ import Type.Reflection
 import qualified Codec.Json.Rpc as Rpc
 import qualified Data.Aeson as Json
 import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
 import qualified Ouroboros.Consensus.HardFork.Combinator as HF
 import qualified Ouroboros.Consensus.Ledger.Query as Ledger
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ
@@ -212,24 +220,51 @@ mkTxSubmissionClient tr defaultWithInternalError TxSubmissionCodecs{..} Executio
     await :: m (TxSubmissionMessage block)
     await = atomically (readTQueue queue)
 
+    isMostRecentEra era =
+        T.toLower (toText era) == T.toLower (toText (eraName @(MostRecentEra block)))
+
+    -- NOTE: On successful submission, clear our cached
+    -- mempool to ensure we always use the latest available
+    -- mempool snapshot during evaluation.
+    clearMempoolOnSuccess = \case
+        SubmitSuccess -> clearMempoolM
+        _ -> pure ()
+
     clientStIdle
         :: m (LocalTxClientStIdle (SerializedTransaction block) (SubmitTransactionError block) m ())
     clientStIdle = await >>= \case
         MsgSubmitTransaction SubmitTransaction{transaction = request} toResponse -> do
             defaultWithInternalError clientStIdle yield toResponse $ case request of
                 MultiEraDecoderSuccess transaction -> do
                     pure $ SendMsgSubmitTx transaction $ \result -> do
-                        -- NOTE: On successful submission, clear our cached
-                        -- mempool to ensure we always use the latest available
-                        -- mempool snapshot during evaluation.
                         case result of
-                            SubmitSuccess -> clearMempoolM
-                            SubmitFail{} -> pure ()
-                        mkSubmitTransactionResponse transaction result
-                            & toResponse
-                            & encodeSubmitTransactionResponse
-                            & yield
-                        clientStIdle
+                            SubmitFail (ApplyTxErrWrongEra eraMismatch) | isMostRecentEra (ledgerEraName eraMismatch) -> do
+                                case upgradeGenTx transaction of
+                                    Left hint -> do
+                                        SubmitTransactionFailedToUpgrade hint
+                                            & toResponse
+                                            & encodeSubmitTransactionResponse
+                                            & yield
+                                        clientStIdle
+                                    Right upgradedTx ->
+                                        pure $ SendMsgSubmitTx upgradedTx $ \result' -> do
+                                            clearMempoolOnSuccess result'
+                                            mkSubmitTransactionResponse transaction result'
+                                                & toResponse
+                                                & encodeSubmitTransactionResponse
+                                                & yield
+                                            clientStIdle
+                            _ -> do
+                                -- NOTE: On successful submission, clear our cached
+                                -- mempool to ensure we always use the latest available
+                                -- mempool snapshot during evaluation.
+                                clearMempoolOnSuccess result
+                                mkSubmitTransactionResponse transaction result
+                                    & toResponse
+                                    & encodeSubmitTransactionResponse
+                                    & yield
+                                clientStIdle
+
                 MultiEraDecoderErrors errs -> do
                     SubmitTransactionDeserialisationFailure errs
                         & toResponse

diff --git a/server/src/Ogmios/Data/EraTranslation.hs b/server/src/Ogmios/Data/EraTranslation.hs
@@ -16,6 +16,7 @@ module Ogmios.Data.EraTranslation
 
       -- * Translations
     , Upgrade (..)
+    , upgradeGenTx
     ) where
 
 import Ogmios.Prelude
@@ -51,13 +52,20 @@ import Data.Maybe.Strict
 import Ouroboros.Consensus.Cardano
     ( CardanoBlock
     )
+import Ouroboros.Consensus.Cardano.Block
+    ( GenTx (..)
+    )
 import Ouroboros.Consensus.Shelley.Ledger
     ( ShelleyBlock
     )
+import Ouroboros.Consensus.Shelley.Ledger.Mempool
+    ( GenTx (..)
+    )
 
 import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
 import qualified Cardano.Ledger.Babbage.TxBody as Babbage
 import qualified Cardano.Ledger.Conway.Core as Conway
+import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as Ledger
 
 type family MostRecentEra block :: Type where
@@ -106,6 +114,35 @@ instance
             let isValid = Alonzo.isValid tx
             pure $ AlonzoTx{body,wits,auxiliaryData,isValid}
 
+----------
+-- GenTx
+----------
+
+upgradeGenTx
+    :: forall crypto.
+        ( Crypto crypto
+        )
+    => GenTx (CardanoBlock crypto)
+    -> Either Text (GenTx (CardanoBlock crypto))
+upgradeGenTx = \case
+    GenTxByron _ ->
+        Left "cannot upgrade from Byron transaction: too old, use a more recent transaction builder."
+    GenTxShelley _ ->
+        Left "cannot upgrade from Shelley transaction: too old, use a more recent transaction builder."
+    GenTxAllegra _ ->
+        Left "cannot upgrade from Allegra transaction: too old, use a more recent transaction builder."
+    GenTxMary _ ->
+        Left "cannot upgrade from Mary transaction: too old, use a more recent transaction builder."
+    GenTxAlonzo (ShelleyTx hash txInAlonzo) -> do
+        txInBabbage <- left show $ Core.upgradeTx @(BabbageEra crypto) txInAlonzo
+        txInConway  <- left show $ Core.upgradeTx @(ConwayEra crypto) txInBabbage
+        pure $ GenTxConway $ ShelleyTx hash txInConway
+    GenTxBabbage (ShelleyTx hash txInBabbage) -> do
+        txInConway <- left show $ Core.upgradeTx @(ConwayEra crypto) txInBabbage
+        pure $ GenTxConway $ ShelleyTx hash txInConway
+    latest@(GenTxConway(_))->
+        Right latest
+
 unsafeFromRight :: (HasCallStack) => Either Text a -> a
 unsafeFromRight = either error id
 

diff --git a/server/src/Ogmios/Data/Protocol/TxSubmission.hs b/server/src/Ogmios/Data/Protocol/TxSubmission.hs
@@ -254,6 +254,7 @@ _decodeSubmitTransaction =
 data SubmitTransactionResponse block
     = SubmitTransactionSuccess (GenTxId block)
     | SubmitTransactionFailure (SubmitTransactionError block)
+    | SubmitTransactionFailedToUpgrade Text
     | SubmitTransactionDeserialisationFailure [(SomeShelleyEra, Binary.DecoderError, Word)]
     deriving (Generic)
 deriving instance
@@ -281,6 +282,16 @@ _encodeSubmitTransactionResponse _proxy
             resolve $ encodeObject ("transaction" .= encodeTransactionId i)
         SubmitTransactionFailure e ->
             encodeSubmitTransactionError reject e
+        SubmitTransactionFailedToUpgrade hint ->
+            reject Rpc.FaultInvalidParams
+                "Non-upgradable transaction; it seems that you're trying to submit a \
+                \transaction in a format that presents incompatibility with the current \
+                \ledger era. The field \"data.hint\" contains possible useful information \
+                \about what went wrong."
+                (pure $ encodeObject
+                    ( "hint" .= encodeText hint
+                    )
+                )
         SubmitTransactionDeserialisationFailure errs ->
             encodeDeserialisationFailure reject errs