Use currentEpoch from wall clock for readDelegation.

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

@@ -184,7 +184,7 @@ import Cardano.Wallet
     , dbLayer
     , dummyChangeAddressGen
     , genesisData
-    , getDelegationSlots
+    , getCurrentEpochSlotting
     , logger
     , manageRewardBalance
     , networkLayer
@@ -1846,17 +1846,15 @@ selectCoinsForJoin ctx@ApiLayer{..}
     --
     poolStatus <- liftIO $ getPoolStatus poolId
     pools <- liftIO knownPools
-    curEpoch <- getCurrentEpoch ctx
     (Write.InAnyRecentEra _era pp, timeTranslation)
         <- liftIO $ W.readNodeTipStateForTxWrite netLayer
     withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> liftIO $ do
         let db = workerCtx ^. typed @(DBLayer IO s)
-        delegationSlots <- liftIO $ getDelegationSlots db netLayer
+        currentEpochSlotting <- liftIO $ getCurrentEpochSlotting netLayer
         action <- liftIO $ WD.joinStakePoolDelegationAction @s
             (contramap MsgWallet $ workerCtx ^. logger)
             db
-            delegationSlots
-            curEpoch
+            currentEpochSlotting
             pools
             poolId
             poolStatus
@@ -1911,8 +1909,9 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT walletId) = do
         let db = workerCtx ^. typed @(DBLayer IO s)
         withdrawal <- W.shelleyOnlyMkSelfWithdrawal @s
             netLayer (txWitnessTagFor @k) db
-        delegationSlots <- liftIO $ getDelegationSlots db netLayer
-        action <- WD.quitStakePoolDelegationAction db delegationSlots withdrawal
+        currentEpochSlotting <- liftIO $ getCurrentEpochSlotting netLayer
+        action <- WD.quitStakePoolDelegationAction
+            db currentEpochSlotting withdrawal
         let changeAddrGen = W.defaultChangeAddressGen (delegationAddressS @n)
         let txCtx = defaultTransactionCtx
                 { txDelegationAction = Just action
@@ -2466,8 +2465,6 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d
         (Write.InAnyRecentEra (_era :: Write.RecentEra era) pp, _)
             <- liftIO $ W.readNodeTipStateForTxWrite netLayer
 
-        epoch <- getCurrentEpoch api
-
         withdrawal <- case body ^. #withdrawal of
             Just SelfWithdraw -> liftIO $
                 W.shelleyOnlyMkSelfWithdrawal
@@ -2479,12 +2476,12 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d
                 , txMetadata = metadata
                 , txValidityInterval = first Just validityInterval
                 }
-        delegationSlots <- liftIO $ getDelegationSlots db netLayer
+        currentEpochSlotting <- liftIO $ getCurrentEpochSlotting netLayer
         optionalDelegationAction <- liftHandler $
             forM delegationRequest $
                 WD.handleDelegationRequest
                     trWorker
-                    db delegationSlots epoch knownPools
+                    db currentEpochSlotting knownPools
                     poolStatus withdrawal
 
         let transactionCtx1 =
@@ -2885,8 +2882,7 @@ constructSharedTransaction
             txLayer = wrk ^. transactionLayer @SharedKey @'CredFromScriptK
             trWorker = MsgWallet >$< wrk ^. logger
 
-        delegationSlots <- liftIO $ getDelegationSlots db netLayer
-        epoch <- getCurrentEpoch api
+        currentEpochSlotting <- liftIO $ getCurrentEpochSlotting netLayer
         (Write.InAnyRecentEra (_ :: Write.RecentEra era) pp, _)
             <- liftIO $ W.readNodeTipStateForTxWrite netLayer
         (cp, _, _) <- handler $ W.readWallet wrk
@@ -2904,7 +2900,7 @@ constructSharedTransaction
         optionalDelegationAction <- liftHandler $
             forM delegationRequest $
                 WD.handleDelegationRequest
-                    trWorker db delegationSlots epoch knownPools
+                    trWorker db currentEpochSlotting knownPools
                     getPoolStatus NoWithdrawal
 
         let txCtx = defaultTransactionCtx
@@ -3537,12 +3533,11 @@ joinStakePool
         SpecificPool pool -> pure pool
     poolStatus <- liftIO (getPoolStatus poolId)
     pools <- liftIO knownPools
-    curEpoch <- getCurrentEpoch ctx
     withWorkerCtx ctx walletId liftE liftE $ \wrk -> do
         let tr = wrk ^. logger
             db = wrk ^. typed @(DBLayer IO s)
             ti = timeInterpreter netLayer
-        delegationSlots <- liftIO $ getDelegationSlots db netLayer
+        currentEpochSlotting <- liftIO $ getCurrentEpochSlotting netLayer
         (BuiltTx{..}, txTime) <- liftIO $
             W.buildSignSubmitTransaction @s
                 db
@@ -3556,8 +3551,7 @@ joinStakePool
                     (MsgWallet >$< tr)
                     ti
                     db
-                    delegationSlots
-                    curEpoch
+                    currentEpochSlotting
                     pools
                     poolId
                     poolStatus

lib/wallet/src/Cardano/Wallet.hs

@@ -112,7 +112,7 @@ module Cardano.Wallet
     , isStakeKeyRegistered
     , putDelegationCertificate
     , readDelegation
-    , getDelegationSlots
+    , getCurrentEpochSlotting
 
     -- * Shared Wallet
     , updateCosigner
@@ -340,7 +340,7 @@ import Cardano.Wallet.DB
 import Cardano.Wallet.DB.Errors
     ( ErrNoSuchWallet (..) )
 import Cardano.Wallet.DB.Store.Delegations.Layer
-    ( ReadDelegationSlots, mkReadDelegationSlots )
+    ( CurrentEpochSlotting, mkCurrentEpochSlotting )
 import Cardano.Wallet.DB.Store.Info.Store
     ( DeltaWalletInfo (..), WalletInfo (..) )
 import Cardano.Wallet.DB.Store.Submissions.Layer
@@ -418,7 +418,6 @@ import Cardano.Wallet.Primitive.Slotting
     , addRelTime
     , ceilingSlotAt
     , currentRelativeTime
-    , epochOf
     , interpretQuery
     , neverFails
     , slotRangeFromTimeRange
@@ -660,6 +659,7 @@ import qualified Cardano.Wallet.DB.Store.Submissions.Layer as Submissions
 import qualified Cardano.Wallet.DB.WalletState as WS
 import qualified Cardano.Wallet.DB.WalletState as WalletState
 import qualified Cardano.Wallet.Primitive.Migration as Migration
+import qualified Cardano.Wallet.Primitive.Slotting as Slotting
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
@@ -912,21 +912,17 @@ putPrivateKey walletState (pk, hpw) = onDBVar walletState $ update $ \_ ->
 readDelegation
     :: Monad stm
     => DBVar stm (DeltaWalletState s)
-    -> stm (ReadDelegationSlots -> WalletDelegation)
+    -> stm (CurrentEpochSlotting -> WalletDelegation)
 readDelegation walletState = do
     dels <- view #delegations <$> readDBVar walletState
     pure $ \dsarg -> Dlgs.readDelegation dsarg dels
 
-getDelegationSlots
-    :: DBLayer IO s
-    -> NetworkLayer IO block
-    -> IO ReadDelegationSlots
-getDelegationSlots DBLayer{..} nl = do
-    cp <- atomically readCheckpoint
-    currentEpoch <-
-        liftIO
-            $ interpretQuery ti (epochOf $ cp ^. #currentTip . #slotNo)
-    mkReadDelegationSlots ti currentEpoch
+getCurrentEpochSlotting
+    :: NetworkLayer IO block
+    -> IO CurrentEpochSlotting
+getCurrentEpochSlotting nl = do
+    epoch <- Slotting.currentEpoch ti
+    mkCurrentEpochSlotting ti epoch
   where
     ti = neverFails "currentEpoch is past horizon" $ timeInterpreter nl
 
@@ -937,7 +933,7 @@ readWallet
     => ctx
     -> IO (Wallet s, (WalletMetadata, WalletDelegation), Set Tx)
 readWallet ctx = do
-    delegationSlots <- getDelegationSlots db nl
+    currentEpochSlotting <- getCurrentEpochSlotting nl
     db & \DBLayer{..} -> atomically $ do
         cp <- readCheckpoint
         meta <- readWalletMeta walletState
@@ -949,7 +945,7 @@ readWallet ctx = do
                 wholeRange
                 (Just Pending)
                 Nothing
-        pure (cp, (meta, dele delegationSlots), Set.fromList (fromTransactionInfo <$> pending))
+        pure (cp, (meta, dele currentEpochSlotting), Set.fromList (fromTransactionInfo <$> pending))
 
   where
     db = ctx ^. dbLayer @IO @s

lib/wallet/src/Cardano/Wallet/DB/Store/Delegations/Layer.hs

@@ -1,12 +1,13 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Wallet.DB.Store.Delegations.Layer
     ( isStakeKeyRegistered
     , putDelegationCertificate
     , readDelegation
-    , ReadDelegationSlots (..)
-    , mkReadDelegationSlots
+    , CurrentEpochSlotting (..)
+    , mkCurrentEpochSlotting
     )
 where
 
@@ -34,9 +35,12 @@ import Data.Function
     ( (&) )
 import Data.Map.Strict
     ( lookupMax )
-import qualified Data.Map.Strict as Map
 import Data.Maybe
     ( catMaybes, fromMaybe )
+import GHC.Generics
+    ( Generic )
+
+import qualified Data.Map.Strict as Map
 
 -- | Check whether the stake key is registered in the delegation state.
 isStakeKeyRegistered :: Delegations -> Bool
@@ -63,18 +67,19 @@ putDelegationCertificate cert sl = case cert of
     CertRegisterKey _ -> [Register sl]
 
 -- | Arguments to 'readDelegation'.
-data ReadDelegationSlots = ReadDelegationSlots
+data CurrentEpochSlotting = CurrentEpochSlotting
     { currentEpoch :: EpochNo
     -- ^ The current epoch.
     , currentEpochStartSlot :: SlotNo
     -- ^ The current epoch start slot.
     , previousEpochStartSlot :: Maybe SlotNo
     -- ^ The previous epoch start slot, if any.
     }
+    deriving (Eq, Show, Generic)
 
 -- | Read the delegation status of a wallet.
-readDelegation :: ReadDelegationSlots -> Delegations -> WalletDelegation
-readDelegation (ReadDelegationSlots epoch cur Nothing) hist =
+readDelegation :: CurrentEpochSlotting -> Delegations -> WalletDelegation
+readDelegation (CurrentEpochSlotting epoch cur Nothing) hist =
     WalletDelegation currentDelegation nextDelegations
   where
     currentDelegation = NotDelegating
@@ -83,7 +88,7 @@ readDelegation (ReadDelegationSlots epoch cur Nothing) hist =
             [ nextDelegation (epoch + 2)
                 $ readDelegationStatus (>= cur) hist
             ]
-readDelegation (ReadDelegationSlots epoch cur (Just prev)) hist =
+readDelegation (CurrentEpochSlotting epoch cur (Just prev)) hist =
     WalletDelegation currentDelegation nextDelegations
   where
     currentDelegation = readDelegationStatus (< prev) hist
@@ -119,16 +124,16 @@ walletDelegationStatus = \case
     Registered -> NotDelegating
     Active pid -> Delegating pid
 
--- | Construct 'ReadDelegationSlots' from an 'EpochNo' using a 'TimeInterpreter'
+-- | Construct 'CurrentEpochSlotting' from an 'EpochNo' using a 'TimeInterpreter'
 -- .
-mkReadDelegationSlots
+mkCurrentEpochSlotting
     :: forall m
      . Monad m
     => TimeInterpreter m
     -> EpochNo
-    -> m ReadDelegationSlots
-mkReadDelegationSlots ti epoch =
-    ReadDelegationSlots epoch
+    -> m CurrentEpochSlotting
+mkCurrentEpochSlotting ti epoch =
+    CurrentEpochSlotting epoch
         <$> slotOf epoch
         <*> case epoch of
             0 -> pure Nothing