Fix inconsistency between the current epoch in the tip and delegation status within the wallet API response

lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster.hs

@@ -1101,15 +1101,15 @@ generateGenesis Config{..} initialFunds genesisMods = do
     If it's slightly before the actual starts, some slots will be missed,
     but it shouldn't be critical as long as less than k slots are missed.
 
-    Empirically, 5 seconds seems to be a good value: enough for a cluster to
+    Empirically, 10 seconds seems to be a good value: enough for a cluster to
     initialize itself before producing any blocks, but not too much to wait for.
 
     Lower values (e.g. 1 second) might cause custer to start but not produce
     any blocks, because the first slot will be too far in the past. When this
     happens then node logs contain TraceNoLedgerView message and wallet log says
     "Current tip is [point genesis]. (not applying blocks)"
     -}
-    systemStart <- addUTCTime 5 <$> getCurrentTime
+    systemStart <- addUTCTime 10 <$> getCurrentTime
 
     let sgProtocolParams = Ledger.emptyPParams
             & ppMinFeeAL .~ Ledger.Coin 100

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

@@ -1164,7 +1164,7 @@ mkShelleyWallet ctx@ApiLayer{..} wid cp meta delegation pending progress = do
     apiDelegation <- liftIO $ toApiWalletDelegation delegation
         (unsafeExtendSafeZone ti)
 
-    tip' <- liftIO $ getWalletTip
+    tip <- liftIO $ getWalletTip
         (neverFails "getWalletTip wallet tip should be behind node tip" ti)
         cp
     let available = availableBalance pending cp
@@ -1186,7 +1186,7 @@ mkShelleyWallet ctx@ApiLayer{..} wid cp meta delegation pending progress = do
         , passphrase = ApiWalletPassphraseInfo
             <$> fmap (view #lastUpdatedAt) (meta ^. #passphraseInfo)
         , state = ApiT progress
-        , tip = tip'
+        , tip
         }
 
 toApiWalletDelegation

lib/wallet/src/Cardano/Wallet.hs

@@ -786,7 +786,6 @@ import UnliftIO.Exception
     , catch
     , evaluate
     , throwIO
-    , try
     )
 import UnliftIO.MVar
     ( modifyMVar_
@@ -1060,25 +1059,12 @@ readDelegation walletState = do
 -- we return the epoch of the node tip.
 getCurrentEpochSlotting
     :: HasCallStack => NetworkLayer IO block -> IO CurrentEpochSlotting
-getCurrentEpochSlotting nl = do
-    epoch <- getCurrentEpoch
-    mkCurrentEpochSlotting ti epoch
-  where
-    ti = Slotting.expectAndThrowFailures $ timeInterpreter nl
-
-    getCurrentEpoch =
-        currentEpochFromWallClock >>= \case
-            Right a -> pure a
-            Left _ -> currentEpochFromNodeTip
-
-    currentEpochFromNodeTip :: IO W.EpochNo
-    currentEpochFromNodeTip = do
-        tip <- currentNodeTip nl
-        interpretQuery ti $ Slotting.epochOf $ tip ^. #slotNo
-
-    currentEpochFromWallClock :: IO (Either PastHorizonException W.EpochNo)
-    currentEpochFromWallClock =
-        try $ Slotting.currentEpoch ti
+getCurrentEpochSlotting nl@NetworkLayer{timeInterpreter} = do
+    tip <- currentNodeTip nl
+    let epochQuery = Slotting.epochOf (tip ^. #slotNo)
+        throwingInterpreter = Slotting.expectAndThrowFailures timeInterpreter
+    epoch <- interpretQuery throwingInterpreter epochQuery
+    mkCurrentEpochSlotting throwingInterpreter epoch
 
 -- | Retrieve the wallet state for the wallet with the given ID.
 readWallet
@@ -1089,7 +1075,7 @@ readWallet ctx = do
     db & \DBLayer{..} -> atomically $ do
         cp <- readCheckpoint
         meta <- readWalletMeta walletState
-        dele <- readDelegation walletState
+        calculateWalletDelegations <- readDelegation walletState
         pending <-
             readTransactions
                 Nothing
@@ -1098,7 +1084,11 @@ readWallet ctx = do
                 (Just Pending)
                 Nothing
                 Nothing
-        pure (cp, (meta, dele currentEpochSlotting), Set.fromList (fromTransactionInfo <$> pending))
+        pure
+            ( cp
+            , (meta, calculateWalletDelegations currentEpochSlotting)
+            , Set.fromList (fromTransactionInfo <$> pending)
+            )
   where
     db = ctx ^. dbLayer
     nl = ctx ^. networkLayer

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Wallet.DB.Store.Delegations.Layer
@@ -40,9 +41,6 @@ import Cardano.Wallet.Primitive.Types
 import Data.Foldable
     ( find
     )
-import Data.Function
-    ( (&)
-    )
 import Data.Map.Strict
     ( lookupMax
     )
@@ -93,50 +91,44 @@ data CurrentEpochSlotting = CurrentEpochSlotting
 
 -- | Read the delegation status of a wallet.
 readDelegation :: CurrentEpochSlotting -> Delegations -> WalletDelegation
-readDelegation (CurrentEpochSlotting epoch cur Nothing) hist =
-    WalletDelegation currentDelegation nextDelegations
-  where
-    currentDelegation = NotDelegating
-    nextDelegations =
-        catMaybes
-            [ nextDelegation (epoch + 2)
-                $ readDelegationStatus (>= cur) hist
-            ]
-readDelegation (CurrentEpochSlotting epoch cur (Just prev)) hist =
-    WalletDelegation currentDelegation nextDelegations
+readDelegation CurrentEpochSlotting{..} history =
+    case previousEpochStartSlot of
+        Nothing ->
+            WalletDelegation
+            { active = NotDelegating
+            , next =
+                catMaybes
+                    [ WalletDelegationNext (currentEpoch + 2) <$>
+                        readDelegationStatus (>= currentEpochStartSlot) history
+                    ]
+            }
+        Just previousEpochStart ->
+            WalletDelegation
+            { active =
+                fromMaybe NotDelegating $
+                    readDelegationStatus (< previousEpochStart) history
+            , next =
+                catMaybes
+                    [ WalletDelegationNext (currentEpoch + 1) <$>
+                        let condition slot
+                                = slot >= previousEpochStart
+                                && slot < currentEpochStartSlot
+                        in readDelegationStatus condition history
+                    , WalletDelegationNext (currentEpoch + 2) <$>
+                        readDelegationStatus (>= currentEpochStartSlot) history
+                    ]
+            }
   where
-    currentDelegation = readDelegationStatus (< prev) hist
-        & fromMaybe NotDelegating
-    nextDelegations =
-        catMaybes
-            [ nextDelegation (epoch + 1)
-                $ readDelegationStatus (\sl -> sl >= prev && sl < cur) hist
-            , nextDelegation (epoch + 2)
-                $ readDelegationStatus (>= cur) hist
-            ]
-
-nextDelegation
-    :: Functor f
-    => EpochNo
-    -> f WalletDelegationStatus
-    -> f WalletDelegationNext
-nextDelegation = fmap . WalletDelegationNext
-
-readDelegationStatus
-    :: (SlotNo -> Bool)
-    -> Delegations
-    -> Maybe WalletDelegationStatus
-readDelegationStatus cond =
-    fmap (walletDelegationStatus . snd)
-        . find (cond . fst)
-        . reverse
-        . Map.assocs
+    readDelegationStatus ::
+        (SlotNo -> Bool) -> Delegations -> Maybe WalletDelegationStatus
+    readDelegationStatus cond =
+        (walletDelegationStatus . snd <$>) . find (cond . fst) . Map.toDescList
 
-walletDelegationStatus :: Status PoolId -> WalletDelegationStatus
-walletDelegationStatus = \case
-    Inactive -> NotDelegating
-    Registered -> NotDelegating
-    Active pid -> Delegating pid
+    walletDelegationStatus :: Status PoolId -> WalletDelegationStatus
+    walletDelegationStatus = \case
+        Inactive -> NotDelegating
+        Registered -> NotDelegating
+        Active pid -> Delegating pid
 
 -- | Construct 'CurrentEpochSlotting' from an 'EpochNo' using a 'TimeInterpreter'
 -- .