Fixes #376

This isn't ideal, but should at least make it work for Ogmios. Ideally, the problem should be fixed in the core consensus code, but the time for this to happen and make it into a node release may be quite significant. So in the meantime, we will cope with it directly in Ogmios at the expense of a minor performance degradation (since we now need 4 requests to provide a true _False_ instead of just one).
CardanoSolutions · Mar 22, 2024 · 8704d71 · 8704d71
1 parent 22e98a1
commit 8704d71
Show file tree

Hide file tree

Showing 19 changed files with 131 additions and 51 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -16,7 +16,7 @@ pre: "<b>5. </b>"
 
 #### Changed
 
-- N/A
+- Retry `HasTx` on false with id wrapped in different eras, to cope with the hard-fork combinator inability to compare transaction id across eras. See also [#376](https://github.com/CardanoSolutions/ogmios/issues/376).
 
 #### Removed
 

diff --git a/server/src/Ogmios/App/Protocol.hs b/server/src/Ogmios/App/Protocol.hs
@@ -47,7 +47,6 @@ import Ogmios.Data.Protocol.StateQuery
     )
 import Ogmios.Data.Protocol.TxMonitor
     ( AcquireMempool
-    , GenTxId
     , HasTransaction
     , NextTransaction
     , ReleaseMempool
@@ -105,8 +104,8 @@ onUnmatchedMessage
         ( FromJSON (MultiEraDecoder (SerializedTransaction block))
         , FromJSON (QueryLedgerState block)
         , FromJSON (Point block)
-        , FromJSON (GenTxId block)
         , FromJSON (MultiEraUTxO block)
+        , Crypto (BlockCrypto block)
         )
     => Rpc.Options
     -> ByteString

diff --git a/server/src/Ogmios/App/Protocol/TxMonitor.hs b/server/src/Ogmios/App/Protocol/TxMonitor.hs
@@ -48,6 +48,9 @@ import Ogmios.Prelude hiding
 import Ogmios.Control.MonadSTM
     ( MonadSTM (..)
     )
+import Ogmios.Data.EraTranslation
+    ( MostRecentEra
+    )
 import Ogmios.Data.Json
     ( Json
     )
@@ -69,21 +72,32 @@ import Ogmios.Data.Protocol.TxMonitor
     , TxMonitorCodecs (..)
     , TxMonitorMessage (..)
     )
+import Ouroboros.Consensus.Cardano
+    ( CardanoBlock
+    )
+import Ouroboros.Consensus.Cardano.Block
+    ( TxId (..)
+    )
 import Ouroboros.Consensus.Ledger.SupportsMempool
     ( HasTxId (..)
     )
+import Ouroboros.Consensus.Shelley.Ledger.Mempool
+    ( TxId (..)
+    )
 import Ouroboros.Network.Protocol.LocalTxMonitor.Client
     ( ClientStAcquired (..)
     , ClientStIdle (..)
     , LocalTxMonitorClient (..)
     )
 
+import qualified Cardano.Ledger.TxIn as Ledger
 import qualified Codec.Json.Rpc as Rpc
 
 mkTxMonitorClient
-    :: forall m block.
+    :: forall m block crypto.
         ( MonadSTM m
         , HasTxId (GenTx block)
+        , block ~ CardanoBlock crypto
         )
     => (forall a r. m a -> (Json -> m ()) -> Rpc.ToResponse r -> m a -> m a)
         -- ^ A default response handler to catch errors.
@@ -141,9 +155,38 @@ mkTxMonitorClient defaultWithInternalError TxMonitorCodecs{..} queue yield =
                     clientStAcquired
         MsgHasTransaction HasTransaction{id} toResponse ->
             defaultWithInternalError clientStAcquired yield toResponse $ do
-                pure $ SendMsgHasTx id $ \has -> do
-                    yield $ encodeHasTransactionResponse $ toResponse $ HasTransactionResponse{has}
-                    clientStAcquired
+                -- NOTE:
+                --
+                -- Unfortunately here, we can't reliably ask the node for a
+                -- transaction id because it performs equality on the GenTxId NS
+                -- wrapper instead of the inner transaction id bytes.
+                --
+                -- As a consequence, sending a transaction id wrapped as a
+                -- GenTxIdAlonzo will not match the same transaction id wrapped
+                -- as a GenTxIdBabbage.
+                --
+                -- Yet, we cannot know upfront in what era those ids are wrapped
+                -- in the mempool although we do commit to a specific NS summand
+                -- when we deserialize it. So we have no other choice than
+                -- retrying the request on `False` with ids wrapped in different
+                -- eras.
+                --
+                -- To be removed once the following issue is addressed:
+                --
+                --   https://github.com/IntersectMBO/ouroboros-consensus/issues/1009
+                loop (inMultipleEras id)
+          where
+            done has = do
+                yield $ encodeHasTransactionResponse $ toResponse $ HasTransactionResponse{has}
+                clientStAcquired
+
+            loop = \case
+                [] -> done False
+                genId:rest -> do
+                    pure $ SendMsgHasTx genId $ \case
+                        True  -> done True
+                        False -> loop rest
+
         MsgSizeOfMempool SizeOfMempool toResponse ->
             defaultWithInternalError clientStAcquired yield toResponse $ do
                 pure $ SendMsgGetSizes $ \mempool -> do
@@ -154,3 +197,24 @@ mkTxMonitorClient defaultWithInternalError TxMonitorCodecs{..} queue yield =
                 pure $ SendMsgRelease $ do
                     yield $ encodeReleaseMempoolResponse $ toResponse Released
                     clientStIdle
+
+inMultipleEras
+    :: forall crypto constraint.
+        ( constraint ~ (MostRecentEra (CardanoBlock crypto) ~ ConwayEra crypto)
+        )
+    => Ledger.TxId crypto
+    -> [GenTxId (CardanoBlock crypto)]
+inMultipleEras id =
+    -- The list is ordered from the "most probable era", down to the least
+    -- probable. This hopefully ensures that we do a minimum number of loops
+    -- for the happy path.
+    [ GenTxIdBabbage (ShelleyTxId id)
+    , GenTxIdConway (ShelleyTxId id)
+    , GenTxIdAlonzo (ShelleyTxId id)
+    , GenTxIdMary (ShelleyTxId id)
+    ]
+  where
+    -- This line exists as a reminder. It will generate a compiler error
+    -- when a new era becomes available. From there, one should update
+    -- the list above to contain that latest era.
+    _compilerWarning = keepRedundantConstraint (Proxy @constraint)
diff --git a/server/src/Ogmios/App/Server/WebSocket.hs b/server/src/Ogmios/App/Server/WebSocket.hs
@@ -118,11 +118,11 @@ import Ogmios.Data.Json
     , encodeDeserialisationFailure
     , encodeEvaluationError
     , encodeExUnits
+    , encodeGenTxId
     , encodePoint
     , encodeSubmitTransactionError
     , encodeTip
     , encodeTx
-    , encodeTxId
     , jsonToByteString
     )
 import Ogmios.Data.Json.Ledger.PredicateFailure
@@ -219,12 +219,12 @@ newWebSocketApp tr unliftIO = do
 
             , mkTxMonitorCodecs
                 opts
-                encodeTxId
+                encodeGenTxId
                 (encodeTx (metadataFormat, includeCbor))
 
             , mkTxSubmissionCodecs
                 opts
-                encodeTxId
+                encodeGenTxId
                 encodeScriptPurposeIndexInAnyEra
                 encodeExUnits
                 encodeEvaluationError

diff --git a/server/src/Ogmios/Data/Json.hs b/server/src/Ogmios/Data/Json.hs
@@ -27,7 +27,8 @@ module Ogmios.Data.Json
     , encodeSubmitTransactionError
     , encodeTip
     , encodeTx
-    , encodeTxId
+    , encodeGenTxId
+    , Shelley.encodeTxId
     , Shelley.encodeTxIn
 
       -- * Decoders
@@ -264,11 +265,11 @@ encodeTx opts = \case
     GenTxByron _ ->
         error "encodeTx: unsupported Byron transaction."
 
-encodeTxId
+encodeGenTxId
     :: Crypto crypto
     => GenTxId (CardanoBlock crypto)
     -> Json
-encodeTxId = encodeObject . \case
+encodeGenTxId = encodeObject . \case
     GenTxIdConway (ShelleyTxId x) ->
         Shelley.encodeTxId x
     GenTxIdBabbage (ShelleyTxId x) ->

diff --git a/server/src/Ogmios/Data/Json/Orphans.hs b/server/src/Ogmios/Data/Json/Orphans.hs
@@ -17,7 +17,6 @@ import Cardano.Ledger.Shelley.UTxO
     )
 import Cardano.Network.Protocol.NodeToClient
     ( GenTx
-    , GenTxId
     )
 import Cardano.Network.Protocol.NodeToClient.Trace
     ( TraceClient
@@ -30,7 +29,6 @@ import Ogmios.Data.Json
     ( decodePoint
     , decodeSerializedTransaction
     , decodeTip
-    , decodeTxId
     , decodeUtxo
     , encodeSerializedTransaction
     , encodeSubmitTransactionError
@@ -97,9 +95,6 @@ instance
     parseJSON = Json.withObject "CBOR" $ \o ->
         o .: "cbor" >>= decodeSerializedTransaction
 
-instance PraosCrypto crypto => FromJSON (GenTxId (CardanoBlock crypto)) where
-    parseJSON = decodeTxId
-
 instance Crypto crypto => FromJSON (MultiEraUTxO (CardanoBlock crypto)) where
     parseJSON = decodeUtxo
 

diff --git a/server/src/Ogmios/Data/Json/Query.hs b/server/src/Ogmios/Data/Json/Query.hs
@@ -130,7 +130,6 @@ import Cardano.Ledger.Shelley.Genesis
     )
 import Cardano.Network.Protocol.NodeToClient
     ( GenTx
-    , GenTxId
     , SerializedTransaction
     )
 import Cardano.Slotting.Block
@@ -164,7 +163,6 @@ import Ouroboros.Consensus.Cardano.Block
     ( BlockQuery (..)
     , CardanoBlock
     , GenTx (..)
-    , TxId (..)
     )
 import Ouroboros.Consensus.HardFork.Combinator
     ( MismatchEraInfo
@@ -197,9 +195,6 @@ import Ouroboros.Consensus.Shelley.Ledger.Block
     ( ShelleyBlock (..)
     , ShelleyHash (..)
     )
-import Ouroboros.Consensus.Shelley.Ledger.Mempool
-    ( TxId (..)
-    )
 import Ouroboros.Consensus.Shelley.Ledger.Query
     ( BlockQuery (..)
     , NonMyopicMemberRewards (..)
@@ -1818,14 +1813,14 @@ decodeTip json =
 decodeTxId
     :: forall crypto. Crypto crypto
     => Json.Value
-    -> Json.Parser (GenTxId (CardanoBlock crypto))
+    -> Json.Parser (Ledger.TxId crypto)
 decodeTxId = Json.withText "TxId" $ \(encodeUtf8 -> utf8) -> do
     bytes <- decodeBase16 utf8
     case hashFromBytes bytes of
         Nothing ->
             fail "couldn't interpret bytes as blake2b-256 digest"
         Just h ->
-            pure $ GenTxIdAlonzo $ ShelleyTxId $ Ledger.TxId (Ledger.unsafeMakeSafeHash h)
+            pure $ Ledger.TxId (Ledger.unsafeMakeSafeHash h)
 
 decodeTxIn
     :: forall crypto. (Crypto crypto)

diff --git a/server/src/Ogmios/Data/Protocol/TxMonitor.hs b/server/src/Ogmios/Data/Protocol/TxMonitor.hs
@@ -79,6 +79,7 @@ import Ouroboros.Network.Protocol.LocalTxMonitor.Type
     ( MempoolSizeAndCapacity (..)
     )
 
+import qualified Cardano.Ledger.TxIn as Ledger
 import qualified Codec.Json.Rpc as Rpc
 import qualified Data.Aeson as Json
 import qualified Data.Aeson.Encoding as Json
@@ -122,7 +123,7 @@ data TxMonitorCodecs block = TxMonitorCodecs
     }
 
 mkTxMonitorCodecs
-    :: (FromJSON (GenTxId block))
+    :: (FromJSON (Ledger.TxId (BlockCrypto block)))
     => Rpc.Options
     -> (GenTxId block -> Json)
     -> (GenTx block -> Json)
@@ -295,14 +296,14 @@ _encodeNextTransactionResponse opts encodeTxId encodeTx =
 -- HasTransaction
 --
 data HasTransaction block
-    = HasTransaction { id :: GenTxId block }
+    = HasTransaction { id :: Ledger.TxId (BlockCrypto block) }
     deriving (Generic)
 deriving instance Show (GenTxId block) => Show (HasTransaction block)
 deriving instance   Eq (GenTxId block) =>   Eq (HasTransaction block)
 
 _encodeHasTransaction
     :: forall block. ()
-    => (GenTxId block -> Json)
+    => (Ledger.TxId (BlockCrypto block) -> Json)
     -> Rpc.Request (HasTransaction block)
     -> Json
 _encodeHasTransaction encodeTxId =
@@ -311,7 +312,7 @@ _encodeHasTransaction encodeTxId =
             encodeTxId id
 
 _decodeHasTransaction
-    :: forall block. (FromJSON (GenTxId block))
+    :: forall block. (FromJSON (Ledger.TxId (BlockCrypto block)))
     => Json.Value
     -> Json.Parser (Rpc.Request (HasTransaction block))
 _decodeHasTransaction =

diff --git a/server/test/unit/Ogmios/App/Protocol/TxMonitorSpec.hs b/server/test/unit/Ogmios/App/Protocol/TxMonitorSpec.hs
@@ -63,8 +63,8 @@ import Ogmios.Control.MonadSTM
     )
 import Ogmios.Data.Json
     ( Json
+    , encodeGenTxId
     , encodeTx
-    , encodeTxId
     )
 import Ogmios.Data.Json.Orphans
     ()
@@ -84,9 +84,15 @@ import Ogmios.Data.Protocol.TxMonitor
     , TxMonitorMessage (..)
     , mkTxMonitorCodecs
     )
+import Ouroboros.Consensus.Cardano.Block
+    ( TxId (..)
+    )
 import Ouroboros.Consensus.Ledger.SupportsMempool
     ( HasTxId (..)
     )
+import Ouroboros.Consensus.Shelley.Ledger
+    ( TxId (ShelleyTxId)
+    )
 import Ouroboros.Network.Protocol.LocalTxMonitor.Type
     ( ClientHasAgency (..)
     , LocalTxMonitor (..)
@@ -138,6 +144,7 @@ import Test.QuickCheck
     , vectorOf
     )
 
+import qualified Cardano.Ledger.TxIn as Ledger
 import qualified Codec.Json.Rpc as Rpc
 import qualified Codec.Json.Rpc.Handler as Rpc
 import qualified Data.Aeson as Json
@@ -213,7 +220,7 @@ withTxMonitorClient
 withTxMonitorClient action seed = do
     (recvQ, sendQ) <- atomically $ (,) <$> newTQueue <*> newTQueue
     let opts = Rpc.defaultOptions
-    let innerCodecs = mkTxMonitorCodecs opts encodeTxId (encodeTx (MetadataNoSchema, omitOptionalCbor))
+    let innerCodecs = mkTxMonitorCodecs opts encodeGenTxId (encodeTx (MetadataNoSchema, omitOptionalCbor))
     let client = mkTxMonitorClient (defaultWithInternalError opts) innerCodecs recvQ (atomically . writeTQueue sendQ)
     let codec = codecs defaultSlotsPerEpoch nodeToClientV_Latest & cTxMonitorCodec
     withMockChannel (txMonitorMockPeer seed codec) $ \channel -> do
@@ -365,8 +372,17 @@ maxCapacity = 10
 plausibleTxs :: [GenTx Block]
 plausibleTxs = generateWith (vectorOf (2 * maxCapacity) genTx) 42
 
-plausibleTxsIds :: [GenTxId Block]
-plausibleTxsIds = txId <$> plausibleTxs
+plausibleTxsIds :: [Ledger.TxId StandardCrypto]
+plausibleTxsIds = unGenTxId . txId <$> plausibleTxs
+  where
+    unGenTxId = \case
+        GenTxIdConway (ShelleyTxId x)  -> x
+        GenTxIdBabbage (ShelleyTxId x) -> x
+        GenTxIdAlonzo (ShelleyTxId x)  -> x
+        GenTxIdMary (ShelleyTxId x)    -> x
+        GenTxIdAllegra (ShelleyTxId x) -> x
+        GenTxIdShelley (ShelleyTxId x) -> x
+        GenTxIdByron _ -> error "GenTxIdByron"
 
 genServerAction :: [tx] -> Gen ServerAction
 genServerAction xs = frequency $ mconcat
@@ -427,7 +443,7 @@ isNextTxResponse :: ResponsePredicate
 isNextTxResponse = ResponsePredicate $
     \v -> ("method" `at` v)  == Just (toJSON @Text "nextTransaction")
 
-hasTx :: Rpc.Mirror -> GenTxId Block -> TxMonitorMessage Block
+hasTx :: Rpc.Mirror -> Ledger.TxId StandardCrypto -> TxMonitorMessage Block
 hasTx mirror tx =
     MsgHasTransaction (HasTransaction tx) (Rpc.Response method mirror)
   where
-Original file line number
+Diff line change
@@ Expand Up / @@ -16,7 +16,7 @@ pre: "<b>5. </b>" @@
     #### Changed
-    - N/A
+    - Retry `HasTx` on false with id wrapped in different eras, to cope with the hard-fork combinator inability to compare transaction id across eras. See also [#376](https://github.com/CardanoSolutions/ogmios/issues/376).
     #### Removed
@@ Expand Down @@