Move retrieval of recent era current protocol parameters to network l…

…ayer
cardano-foundation · Nov 17, 2023 · 73a6835 · 73a6835
1 parent fd9eb91
commit 73a6835
Show file tree

Hide file tree

Showing 8 changed files with 59 additions and 56 deletions.
diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs
@@ -23,7 +23,8 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- suppress false warning
+-- suppress false warning
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 -- |
@@ -477,7 +478,6 @@ import Cardano.Wallet.Primitive.Types
     , DelegationCertificate (..)
     , GenesisParameters (..)
     , NetworkParameters (..)
-    , ProtocolParameters (..)
     , Range (..)
     , Signature (..)
     , Slot
@@ -760,6 +760,7 @@ import GHC.TypeNats
     )
 import Internal.Cardano.Write.Tx
     ( recentEra
+    , toRecentEraGADT
     )
 import Internal.Cardano.Write.Tx.Balance
     ( ChangeAddressGen (..)
@@ -2057,16 +2058,11 @@ readNodeTipStateForTxWrite
     -> IO (Write.InAnyRecentEra Write.ProtocolParameters, TimeTranslation)
 readNodeTipStateForTxWrite netLayer = do
     timeTranslation <- toTimeTranslation (timeInterpreter netLayer)
-
-    res <- currentLedgerProtocolParameters
-        <$> currentProtocolParameters netLayer
-
-    case Write.toRecentEraGADT res of
+    mpp <- currentProtocolParametersInRecentEras netLayer
+    case toRecentEraGADT mpp of
+        Left nopp -> throwIO $ ExceptionWriteTxEra
+            $ ErrNodeNotYetInRecentEra nopp
         Right pp -> pure (pp, timeTranslation)
-        Left era -> throwIO $ invalidEra era
-  where
-    invalidEra =
-        ExceptionWriteTxEra . ErrNodeNotYetInRecentEra
 
 -- | Build, Sign, Submit transaction.
 --

diff --git a/lib/wallet/src/Cardano/Wallet/Byron/Compatibility.hs b/lib/wallet/src/Cardano/Wallet/Byron/Compatibility.hs
@@ -116,7 +116,6 @@ import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut as W
     ( TxOut (TxOut)
     )
 import qualified Data.Map.Strict as Map
-import qualified Internal.Cardano.Write.Tx as Write
 import qualified Ouroboros.Consensus.Block as O
 
 --------------------------------------------------------------------------------
@@ -167,7 +166,6 @@ mainnetNetworkParameters =
                   maximumCollateralInputCount = 0
                 , minimumCollateralPercentage = 0
                 , executionUnitPrices = Nothing
-                , currentLedgerProtocolParameters = Write.InNonRecentEraByron
                 }
         }
 
@@ -310,7 +308,6 @@ protocolParametersFromPP eraInfo pp =
           maximumCollateralInputCount = 0
         , minimumCollateralPercentage = 0
         , executionUnitPrices = Nothing
-        , currentLedgerProtocolParameters = Write.InNonRecentEraByron
         }
   where
     fromBound (Bound _relTime _slotNo (O.EpochNo e)) =

diff --git a/lib/wallet/src/Cardano/Wallet/Network.hs b/lib/wallet/src/Cardano/Wallet/Network.hs
@@ -123,6 +123,9 @@ import Fmt
 import GHC.Generics
     ( Generic
     )
+import Internal.Cardano.Write.Tx
+    ( MaybeInRecentEra
+    )
 import NoThunks.Class
     ( AllowThunksIn (..)
     , NoThunks (..)
@@ -141,6 +144,7 @@ import UnliftIO.Concurrent
     )
 
 import qualified Data.List.NonEmpty as NE
+import qualified Internal.Cardano.Write.ProtocolParameters as Write
 
 {-------------------------------------------------------------------------------
     ChainSync
@@ -177,6 +181,10 @@ data NetworkLayer m block = NetworkLayer
         -- ^ Get the last known protocol parameters. In principle, these can
         -- only change once per epoch.
 
+    , currentProtocolParametersInRecentEras
+        :: m (MaybeInRecentEra Write.ProtocolParameters)
+        -- ^ Get the last known protocol parameters for recent eras.
+
     , currentSlottingParameters
         :: m SlottingParameters
         -- ^ Get the last known slotting parameters. In principle, these can

diff --git a/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs b/lib/wallet/src/Cardano/Wallet/Primitive/Types.hs
@@ -307,9 +307,6 @@ import GHC.Generics
 import GHC.Stack
     ( HasCallStack
     )
-import Internal.Cardano.Write.Tx
-    ( MaybeInRecentEra
-    )
 import Network.URI
     ( URI (..)
     , uriToString
@@ -327,7 +324,6 @@ import Test.QuickCheck
 
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import qualified Internal.Cardano.Write.ProtocolParameters as Write
 
 {-------------------------------------------------------------------------------
                              Wallet Metadata
@@ -947,10 +943,6 @@ data ProtocolParameters = ProtocolParameters
         -- used to determine the fee for the use of a script within a
         -- transaction, based on the 'ExecutionUnits' needed by the use of
         -- the script.
-    , currentLedgerProtocolParameters
-        :: MaybeInRecentEra Write.ProtocolParameters
-        -- ^ The full, raw ledger protocol parameters for writing (constructing)
-        -- transactions in case the node is in a recent era.
     } deriving (Eq, Generic, Show)
 
 instance NFData ProtocolParameters where

diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -414,8 +414,6 @@ import qualified Data.ByteString.Short as SBS
 import qualified Data.ListMap as ListMap
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-import qualified Internal.Cardano.Write.ProtocolParameters as Write
-import qualified Internal.Cardano.Write.Tx as Write
 import qualified Ouroboros.Consensus.Protocol.Praos as Consensus
 import qualified Ouroboros.Consensus.Protocol.Praos.Header as Consensus
 import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
@@ -632,7 +630,6 @@ fromShelleyPParams eraInfo pp =
         , maximumCollateralInputCount = 0
         , minimumCollateralPercentage = 0
         , executionUnitPrices = Nothing
-        , currentLedgerProtocolParameters = Write.InNonRecentEraShelley
         }
 
 fromAllegraPParams
@@ -653,7 +650,6 @@ fromAllegraPParams eraInfo pp =
         , maximumCollateralInputCount = 0
         , minimumCollateralPercentage = 0
         , executionUnitPrices = Nothing
-        , currentLedgerProtocolParameters = Write.InNonRecentEraAllegra
         }
 
 fromMaryPParams
@@ -674,7 +670,6 @@ fromMaryPParams eraInfo pp =
         , maximumCollateralInputCount = 0
         , minimumCollateralPercentage = 0
         , executionUnitPrices = Nothing
-        , currentLedgerProtocolParameters = Write.InNonRecentEraMary
         }
 
 fromBoundToEpochNo :: Bound -> W.EpochNo
@@ -703,7 +698,6 @@ fromAlonzoPParams eraInfo pp =
             pp ^. ppCollateralPercentageL
         , executionUnitPrices =
             Just $ executionUnitPricesFromPParams pp
-        , currentLedgerProtocolParameters = Write.InNonRecentEraAlonzo
         }
 
 fromBabbagePParams
@@ -729,8 +723,6 @@ fromBabbagePParams eraInfo pp =
             pp ^. ppCollateralPercentageL
         , executionUnitPrices =
             Just $ executionUnitPricesFromPParams pp
-        , currentLedgerProtocolParameters =
-            Write.InRecentEraBabbage $ Write.ProtocolParameters pp
         }
 
 fromConwayPParams
@@ -755,8 +747,6 @@ fromConwayPParams eraInfo pp =
                     (error "Maximum count of collateral inputs exceeds 2^16")
         , minimumCollateralPercentage = pp ^. ppCollateralPercentageL
         , executionUnitPrices = Just $ executionUnitPricesFromPParams pp
-        , currentLedgerProtocolParameters =
-            Write.InRecentEraConway $ Write.ProtocolParameters pp
         }
 
 -- | Extract the current network decentralization level from the given set of

diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Network/Node.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -22,6 +23,7 @@
 --     - In particular sections 4.1, 4.2, 4.6 and 4.8
 module Cardano.Wallet.Shelley.Network.Node
     ( withNetworkLayer
+    , NetworkParams(..)
     , Observer (query, startObserving, stopObserving)
     , newObserver
     , ObserverLog (..)
@@ -184,7 +186,6 @@ import Control.Retry
     )
 import Control.Tracer
     ( Tracer (..)
-    , contramap
     , nullTracer
     , traceWith
     )
@@ -201,7 +202,8 @@ import Data.Functor
     ( ($>)
     )
 import Data.Functor.Contravariant
-    ( (>$<)
+    ( Contravariant (..)
+    , (>$<)
     )
 import Data.List
     ( isInfixOf
@@ -247,6 +249,9 @@ import Fmt
 import GHC.Stack
     ( HasCallStack
     )
+import Internal.Cardano.Write.Tx
+    ( MaybeInRecentEra (..)
+    )
 import Network.Mux
     ( MuxError (..)
     , MuxErrorType (..)
@@ -405,6 +410,7 @@ import qualified Codec.CBOR.Term as CBOR
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
+import qualified Internal.Cardano.Write.ProtocolParameters as Write
 import qualified Ouroboros.Consensus.Byron.Ledger as Byron
 import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley
 
@@ -440,6 +446,14 @@ withNetworkLayer tr pipeliningStrategy np conn ver tol action = do
         tol
         action
 
+-- | Network parameters and protocol parameters for the node's current tip.
+data NetworkParams = NetworkParams
+    { protocolParams :: MaybeInRecentEra Write.ProtocolParameters
+    , protocolParamsLegacy :: W.ProtocolParameters
+    , slottingParamsLegacy :: W.SlottingParameters
+    }
+    deriving (Eq, Show)
+
 withNodeNetworkLayerBase
     :: HasCallStack
     => Tracer IO Log
@@ -511,9 +525,13 @@ withNodeNetworkLayerBase
                 , watchNodeTip =
                     _watchNodeTip readNodeTip
                 , currentProtocolParameters =
-                    fst <$> atomically (readTMVar networkParamsVar)
+                    protocolParamsLegacy
+                        <$> atomically (readTMVar networkParamsVar)
+                , currentProtocolParametersInRecentEras =
+                    protocolParams <$> atomically (readTMVar networkParamsVar)
                 , currentSlottingParameters =
-                    snd <$> atomically (readTMVar networkParamsVar)
+                    slottingParamsLegacy
+                        <$> atomically (readTMVar networkParamsVar)
                 , postTx =
                     _postTx txSubmissionQ readCurrentNodeEra
                 , stakeDistribution =
@@ -539,7 +557,7 @@ withNodeNetworkLayerBase
             => RetryHandlers
             -> IO
                 ( STM IO (Tip (CardanoBlock StandardCrypto))
-                , TMVar IO (W.ProtocolParameters, W.SlottingParameters)
+                , TMVar IO NetworkParams
                 , TMVar IO (CardanoInterpreter StandardCrypto)
                 , TMVar IO AnyCardanoEra
                 , TQueue
@@ -559,7 +577,7 @@ withNodeNetworkLayerBase
                 mkWalletToNodeProtocols
                     tr
                     np
-                    (curry (atomically . repsertTMVar networkParamsVar))
+                    (atomically . repsertTMVar networkParamsVar)
                     (atomically . repsertTMVar interpreterVar)
                     (atomically . repsertTMVar eraVar)
                     txSubmissionQ
@@ -821,7 +839,7 @@ mkWalletToNodeProtocols
     -- ^ Base trace for underlying protocols
     -> W.NetworkParameters
     -- ^ Initial blockchain parameters
-    -> (W.ProtocolParameters -> W.SlottingParameters -> m ())
+    -> ( NetworkParams -> m ())
     -- ^ Notifier callback for when parameters for tip change.
     -> (CardanoInterpreter StandardCrypto -> m ())
     -- ^ Notifier callback for when time interpreter is updated.
@@ -850,10 +868,11 @@ mkWalletToNodeProtocols
 
         tipVar <- newTVarIO (Just $ AnyCardanoEra ByronEra, TipGenesis)
 
-        (onPParamsUpdate' :: (W.ProtocolParameters, W.SlottingParameters) -> m ()) <-
-            debounce $ \(pp, sp) -> do
-                traceWith tr $ MsgProtocolParameters pp sp
-                onPParamsUpdate pp sp
+        onPParamsUpdate' <-
+            debounce $ \networkParams@NetworkParams{..} -> do
+                traceWith tr $ MsgProtocolParameters
+                    protocolParamsLegacy slottingParamsLegacy
+                onPParamsUpdate networkParams
 
         let queryParams = do
                 eraBounds <-
@@ -895,8 +914,18 @@ mkWalletToNodeProtocols
                         ( fromConwayPParams eraBounds
                             <$> LSQry Shelley.GetCurrentPParams
                         )
-
-                return (pp, sp)
+                ppEra <- onAnyEra
+                    (pure InNonRecentEraByron)
+                    (pure InNonRecentEraShelley)
+                    (pure InNonRecentEraAllegra)
+                    (pure InNonRecentEraMary)
+                    (pure InNonRecentEraAlonzo)
+                    (InRecentEraBabbage . Write.ProtocolParameters
+                        <$> LSQry Shelley.GetCurrentPParams)
+                    (InRecentEraConway . Write.ProtocolParameters
+                        <$> LSQry Shelley.GetCurrentPParams)
+
+                return $ NetworkParams ppEra pp sp
 
         let queryInterpreter = LSQry (QueryHardFork GetInterpreter)
 

diff --git a/lib/wallet/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs b/lib/wallet/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs
@@ -98,8 +98,6 @@ import GHC.Stack
 
 import qualified Cardano.Api.Shelley as C
 import qualified Data.ByteString.Char8 as B8
-import qualified Internal.Cardano.Write.ProtocolParameters as Write
-import qualified Internal.Cardano.Write.Tx as Write
 
 {-----------------------------------------------------------------------------
     Dummy values
@@ -168,12 +166,6 @@ dummyProtocolParameters = ProtocolParameters
             { pricePerStep = 7.21e-5
             , pricePerMemoryUnit = 0.057_7
             }
-    , currentLedgerProtocolParameters =
-        Write.InRecentEraBabbage . Write.ProtocolParameters $
-            either (error . show) id $
-                C.toLedgerPParams
-                    C.ShelleyBasedEraBabbage
-                    dummyNodeProtocolParameters
     }
 
 -- | Dummy parameters that are consistent with the @dummy*@ parameters.
@@ -227,6 +219,8 @@ dummyNetworkLayer = NetworkLayer
     , currentNodeTip = err "currentNodeTip"
     , watchNodeTip = err "watchNodeTip"
     , currentProtocolParameters = err "currentProtocolParameters"
+    , currentProtocolParametersInRecentEras
+        = err "currentProtocolParametersInRecentEras"
     , currentSlottingParameters = err "currentSlottingParameters"
     , postTx = err "postTx"
     , stakeDistribution = err "stakeDistribution"

diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/Arbitrary.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/Arbitrary.hs
@@ -341,7 +341,6 @@ import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.List as L
 import qualified Data.Map.Strict as Map
-import qualified Internal.Cardano.Write.Tx as Write
 
 {-------------------------------------------------------------------------------
                                  Modifiers
@@ -815,7 +814,6 @@ instance Arbitrary ProtocolParameters where
         <:> shrink
         <:> shrink
         <:> shrink
-        <:> const []
         <:> Nil
     arbitrary = ProtocolParameters
         <$> arbitrary
@@ -826,7 +824,6 @@ instance Arbitrary ProtocolParameters where
         <*> genMaximumCollateralInputCount
         <*> genMinimumCollateralPercentage
         <*> arbitrary
-        <*> pure Write.InNonRecentEraAlonzo
       where
         genMaximumCollateralInputCount :: Gen Word16
         genMaximumCollateralInputCount = arbitrarySizedNatural