From f46288aa251e54dc2399215754c1a222d8fbba9a Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 6 Nov 2023 11:30:21 +0100 Subject: [PATCH 1/5] chore: simplify binding name by removng ' --- lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs index 51be730528e..d424268b80c 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs +++ b/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 From 13b6dd755bea9545b857d41847b3063b17448e2e Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 6 Nov 2023 11:31:14 +0100 Subject: [PATCH 2/5] Make integration test more stable by giving cluster +5s to start. --- lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster.hs b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster.hs index c7deeb3b254..876305d5161 100644 --- a/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster.hs +++ b/lib/local-cluster/lib/Cardano/Wallet/Launch/Cluster.hs @@ -1101,7 +1101,7 @@ 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 @@ -1109,7 +1109,7 @@ generateGenesis Config{..} initialFunds genesisMods = do 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 From 32f6134aca0bf28252178fd5c1f8eaa59d3441df Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 6 Nov 2023 11:33:06 +0100 Subject: [PATCH 3/5] chore, refactor: readDelegation code is more grokkable --- .../Wallet/DB/Store/Delegations/Layer.hs | 82 +++++++++---------- 1 file changed, 37 insertions(+), 45 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet/DB/Store/Delegations/Layer.hs b/lib/wallet/src/Cardano/Wallet/DB/Store/Delegations/Layer.hs index e3c7f983fe5..a8250a8b60f 100644 --- a/lib/wallet/src/Cardano/Wallet/DB/Store/Delegations/Layer.hs +++ b/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' -- . From 1c13a11c5e4d3b614c32a218959dda70028ffec6 Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 6 Nov 2023 11:33:50 +0100 Subject: [PATCH 4/5] chore: better binding naming --- lib/wallet/src/Cardano/Wallet.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 57a3f43d8bf..89b78414c3d 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -1089,7 +1089,7 @@ readWallet ctx = do db & \DBLayer{..} -> atomically $ do cp <- readCheckpoint meta <- readWalletMeta walletState - dele <- readDelegation walletState + calculateWalletDelegations <- readDelegation walletState pending <- readTransactions Nothing @@ -1098,7 +1098,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 From e9a356e3fcb773a64cba94e2a9448428bf95482b Mon Sep 17 00:00:00 2001 From: Yura Lazarev Date: Mon, 6 Nov 2023 11:34:36 +0100 Subject: [PATCH 5/5] fix: don't calculate current epoch from relative time, always calculate it from the node tip instead. --- lib/wallet/src/Cardano/Wallet.hs | 26 ++++++-------------------- 1 file changed, 6 insertions(+), 20 deletions(-) diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 89b78414c3d..9eb6726bcc6 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/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