Signal wallet tip changes

cardano-foundation · Dec 6, 2024 · 8791b55 · 8791b55
1 parent 4456ffe
commit 8791b55
Show file tree

Hide file tree

Showing 8 changed files with 74 additions and 34 deletions.
diff --git a/lib/customer-deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs b/lib/customer-deposit-wallet/http/Cardano/Wallet/Deposit/HTTP/Server.hs
@@ -68,25 +68,30 @@ api :: Proxy API
 api = Proxy
 
 server
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> FilePath
     -> WalletBootEnv IO
     -> WalletResource
     -> Server API
-server tr dbDir wb r =
+server wtc tr dbDir wb r =
     listCustomerH r
         :<|> queryAddressH r
-        :<|> createWalletViaMnemonic tr dbDir wb r
-        :<|> createWalletViaXPub tr dbDir wb r
+        :<|> createWalletViaMnemonic wtc tr dbDir wb r
+        :<|> createWalletViaXPub wtc tr dbDir wb r
 
 createWalletViaMnemonic
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> FilePath
     -> WalletBootEnv IO
     -> WalletResource
     -> PostWalletViaMnemonic
     -> Handler NoContent
 createWalletViaMnemonic
+    wtc
     tracer
     dir
     boot
@@ -99,6 +104,7 @@ createWalletViaMnemonic
                     initWallet :: WalletResourceM ()
                     initWallet =
                         REST.initWallet
+                            wtc
                             tracer
                             boot
                             dir
@@ -107,13 +113,16 @@ createWalletViaMnemonic
                 onlyOnWalletIntance resource initWallet $> NoContent
 
 createWalletViaXPub
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> FilePath
     -> WalletBootEnv IO
     -> WalletResource
     -> PostWalletViaXPub
     -> Handler NoContent
 createWalletViaXPub
+    wtc
     tracer
     dir
     boot
@@ -130,6 +139,7 @@ createWalletViaXPub
             Right credentials ->
                 Right
                     <$> REST.initWallet
+                        wtc
                         tracer
                         boot
                         dir

diff --git a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs
@@ -337,18 +337,20 @@ createTheDepositWalletOnDisk _tr dir credentials users action = do
 
 -- | Load an existing wallet from disk.
 loadWallet
-    :: WalletIO.WalletBootEnv IO
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> WalletIO.WalletBootEnv IO
     -- ^ Environment for the wallet
     -> FilePath
     -- ^ Path to the wallet database directory
     -> WalletResourceM ()
-loadWallet bootEnv dir = do
+loadWallet wtc bootEnv dir = do
     let action
             :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b)
         action f = findTheDepositWalletOnDisk bootEnv dir $ \case
             Right wallet ->
                 Right
-                    <$> WalletIO.withWalletLoad
+                    <$> WalletIO.withWalletLoad wtc
                         (WalletIO.WalletEnv bootEnv wallet)
                         f
             Left e -> pure $ Left $ ErrLoadingDatabase e
@@ -360,7 +362,9 @@ loadWallet bootEnv dir = do
 
 -- | Initialize a new wallet from an 'XPub'.
 initWallet
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -- ^ Tracer for logging
     -> WalletIO.WalletBootEnv IO
     -- ^ Environment for the wallet
@@ -371,13 +375,13 @@ initWallet
     -> Word31
     -- ^ Max number of users ?
     -> WalletResourceM ()
-initWallet tr bootEnv dir credentials users = do
+initWallet wtc tr bootEnv dir credentials users = do
     let action
             :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b)
         action f = createTheDepositWalletOnDisk tr dir credentials users $ \case
             Just wallet -> do
                 fmap Right
-                    $ WalletIO.withWalletInit
+                    $ WalletIO.withWalletInit wtc
                         (WalletIO.WalletEnv bootEnv wallet)
                         credentials
                         users

diff --git a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST/Start.hs
@@ -49,17 +49,19 @@ lg :: (MonadIO m, Show a) => Tracer IO String -> String -> a -> m ()
 lg tr p x = liftIO $ traceWith tr $ p <> ": " <> show x
 
 loadDepositWalletFromDisk
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> FilePath
     -> WalletBootEnv IO
     -> WalletResource
     -> IO ()
-loadDepositWalletFromDisk tr dir env resource = do
+loadDepositWalletFromDisk wtc tr dir env resource = do
     result <- flip runWalletResourceM resource $ do
         test <- liftIO $ walletExists dir
         when test $ do
             lg tr "Loading wallet from" dir
-            loadWallet env dir
+            loadWallet wtc env dir
             lg tr "Wallet loaded from" dir
         pure test
     case result of

diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs
@@ -90,6 +90,7 @@ import Cardano.Wallet.Network.Checkpoints.Policy
 import Control.Tracer
     ( Tracer
     , contramap
+    , traceWith
     )
 import Data.Bifunctor
     ( first
@@ -175,12 +176,14 @@ readWalletState WalletInstance{walletState} =
 
 -- | Initialize a new wallet in the given environment.
 withWalletInit
-    :: WalletEnv IO
+    :: Tracer IO () -- wallet tip changes
+    -> WalletEnv IO
     -> Credentials
     -> Word31
     -> (WalletInstance -> IO a)
     -> IO a
 withWalletInit
+    wtc
     env@WalletEnv
         { bootEnv = WalletBootEnv{genesisData}
         , ..
@@ -194,23 +197,26 @@ withWalletInit
                     credentials
                     knownCustomerCount
                     genesisData
-        withWalletDBVar env walletState action
+        withWalletDBVar wtc env walletState action
 
 -- | Load an existing wallet from the given environment.
 withWalletLoad
-    :: WalletEnv IO
+    :: Tracer IO () -- wallet tip changes
+    -> WalletEnv IO
     -> (WalletInstance -> IO a)
     -> IO a
-withWalletLoad env@WalletEnv{..} action = do
+withWalletLoad wtc env@WalletEnv{..} action = do
     walletState <- DBVar.loadDBVar store
-    withWalletDBVar env walletState action
+    withWalletDBVar wtc env walletState action
 
 withWalletDBVar
-    :: WalletEnv IO
+    :: Tracer IO () -- wallet tip changes
+    -> WalletEnv IO
     -> DBVar.DBVar IO Wallet.DeltaWalletState
     -> (WalletInstance -> IO a)
     -> IO a
 withWalletDBVar
+    wtc
     env@WalletEnv{bootEnv = WalletBootEnv{logger, networkEnv}}
     walletState
     action = do
@@ -228,7 +234,7 @@ withWalletDBVar
                         [ walletTip
                         , Read.GenesisPoint
                         ]
-                , rollForward = rollForward w
+                , rollForward = rollForward w wtc
                 , rollBackward = rollBackward w
                 }
 
@@ -294,17 +300,19 @@ getAllDeposits w i =
 
 rollForward
     :: WalletInstance
+    -> Tracer IO () -- wallet tip changes
     -> NonEmpty (Read.EraValue Read.Block)
     -> tip
     -> IO ()
-rollForward w blocks _nodeTip = do
+rollForward w wtc blocks _nodeTip = do
     timeFromSlot <- slotResolver w
     onWalletState w
         $ Delta.update
         $ Delta.Replace
             . Wallet.rollForwardMany
                 timeFromSlot
                 blocks
+    traceWith wtc ()
     x <- readWalletState w
     x `seq` pure ()
 

diff --git a/lib/exe/lib/Cardano/Wallet/Application.hs b/lib/exe/lib/Cardano/Wallet/Application.hs
@@ -188,6 +188,7 @@ import Cardano.Wallet.UI.Common.Layer
     , UILayer
     , oobMessages
     , sourceOfNewTip
+    , walletTipChanges
     )
 import Control.Exception.Extra
     ( handle
@@ -208,6 +209,7 @@ import Control.Monad.Trans.Except
     )
 import Control.Tracer
     ( Tracer (..)
+    , nullTracer
     , traceWith
     )
 import Data.Function
@@ -425,15 +427,16 @@ serveWallet
                                             "deposit-wallet"
                                 Just databaseDir' -> pure databaseDir'
                             resource <- ContT withResource
+                            ui <- Ui.withUILayer 1 resource
                             liftIO
                                 $ loadDepositWalletFromDisk
+                                    (walletTipChanges >$< oobMessages ui)
                                     ( DepositApplicationLog
                                         >$< applicationTracer
                                     )
                                     databaseDir'
                                     bootEnv
                                     resource
-                            ui <- Ui.withUILayer 1 resource
                             REST.onResourceChange
                                 ( \_ -> do
                                     traceWith (oobMessages ui)
@@ -471,6 +474,7 @@ serveWallet
                                         resource <- ContT withResource
                                         liftIO
                                             $ loadDepositWalletFromDisk
+                                                nullTracer
                                                 ( DepositApplicationLog
                                                     >$< applicationTracer
                                                 )
@@ -633,6 +637,7 @@ serveWallet
                         application =
                             Server.serve api
                                 $ Deposit.server
+                                    nullTracer
                                     (DepositApplicationLog >$< applicationTracer)
                                     databaseDir'
                                     bootEnv
@@ -668,6 +673,7 @@ serveWallet
                     application =
                         Server.serve api
                             $ DepositUi.serveUI
+                                (walletTipChanges >$< oobMessages ui)
                                 (DepositUIApplicationLog >$< applicationTracer)
                                 ui
                                 bootEnv

diff --git a/lib/ui/src/Cardano/Wallet/UI/Common/Layer.hs b/lib/ui/src/Cardano/Wallet/UI/Common/Layer.hs
@@ -13,6 +13,7 @@ module Cardano.Wallet.UI.Common.Layer
     , stateL
     , sseEnabled
     , sourceOfNewTip
+    , walletTipChanges
     )
 where
 
@@ -124,6 +125,9 @@ data SessionLayer s = SessionLayer
 messageOfPush :: Push -> Message
 messageOfPush (Push x) = Message x mempty
 
+walletTipChanges :: () -> Push
+walletTipChanges _ = Push "wallet-tip"
+
 -- | Create a session layer giver the state and the server-sent events channel.
 mkSession :: TVar (State s) -> TChan Message -> SessionLayer s
 mkSession var sseChan =

diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server.hs
@@ -157,7 +157,9 @@ import qualified Data.ByteString.Lazy as BL
 serveUI
     :: forall n
      . HasSNetworkId n
-    => Tracer IO String
+    => Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> UILayer WalletResource
     -> WalletBootEnv IO
     -> FilePath
@@ -166,7 +168,7 @@ serveUI
     -> NetworkLayer IO Read.ConsensusBlock
     -> BlockchainSource
     -> Server UI
-serveUI tr ul env dbDir config nid nl bs =
+serveUI wtc tr ul env dbDir config nid nl bs =
     serveTabPage ul config Wallet
         :<|> serveTabPage ul config About
         :<|> serveTabPage ul config Network
@@ -182,8 +184,8 @@ serveUI tr ul env dbDir config nid nl bs =
         :<|> serveFavicon
         :<|> serveMnemonic
         :<|> serveWalletPage (networkEnv env) ul
-        :<|> servePostMnemonicWallet tr env dbDir ul
-        :<|> servePostXPubWallet tr env dbDir ul
+        :<|> servePostMnemonicWallet wtc tr env dbDir ul
+        :<|> servePostXPubWallet wtc tr env dbDir ul
         :<|> serveDeleteWallet ul dbDir
         :<|> serveDeleteWalletModal ul
         :<|> serveGetAddress ul

diff --git a/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Wallet.hs b/lib/ui/src/Cardano/Wallet/UI/Deposit/Server/Wallet.hs
@@ -97,34 +97,38 @@ serveWalletPage nenv ul = withSessionLayer ul $ \layer -> do
         renderSmoothHtml $ walletElementH alertH presence status
 
 servePostMnemonicWallet
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> WalletBootEnv IO
     -> FilePath
     -> UILayer WalletResource
     -> PostWalletViaMnemonic
     -> Maybe RequestCookies
     -> Handler (CookieResponse RawHtml)
-servePostMnemonicWallet tr env dbDir ul request =
+servePostMnemonicWallet wtc tr env dbDir ul request =
     withSessionLayer ul $ \layer -> do
         postMnemonicWallet layer initWallet' alert ok request
   where
     ok _ = renderHtml . rogerH @Text $ "ok"
-    initWallet' = initWallet tr env dbDir
+    initWallet' = initWallet wtc tr env dbDir
 
 servePostXPubWallet
-    :: Tracer IO String
+    :: Tracer IO ()
+    -- ^ Tracer for wallet tip changes
+    -> Tracer IO String
     -> WalletBootEnv IO
     -> FilePath
     -> UILayer WalletResource
     -> PostWalletViaXPub
     -> Maybe RequestCookies
     -> Handler (CookieResponse RawHtml)
-servePostXPubWallet tr env dbDir ul request =
+servePostXPubWallet wtc tr env dbDir ul request =
     withSessionLayer ul $ \layer -> do
         postXPubWallet layer initWallet' alert ok request
   where
     ok _ = renderHtml . rogerH @Text $ "ok"
-    initWallet' = initWallet tr env dbDir
+    initWallet' = initWallet wtc tr env dbDir
 
 serveDeleteWallet
     :: UILayer WalletResource