From 8791b558de2c16aef1bf78ac41595613f66f6815 Mon Sep 17 00:00:00 2001 From: paolino Date: Sat, 30 Nov 2024 19:02:06 +0000 Subject: [PATCH] Signal wallet tip changes --- .../Cardano/Wallet/Deposit/HTTP/Server.hs | 22 ++++++++++++----- .../rest/Cardano/Wallet/Deposit/REST.hs | 16 ++++++++----- .../rest/Cardano/Wallet/Deposit/REST/Start.hs | 8 ++++--- .../src/Cardano/Wallet/Deposit/IO.hs | 24 ++++++++++++------- lib/exe/lib/Cardano/Wallet/Application.hs | 8 ++++++- lib/ui/src/Cardano/Wallet/UI/Common/Layer.hs | 4 ++++ .../src/Cardano/Wallet/UI/Deposit/Server.hs | 10 ++++---- .../Wallet/UI/Deposit/Server/Wallet.hs | 16 ++++++++----- 8 files changed, 74 insertions(+), 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 index fa936209323..e16def75ebe 100644 --- 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 index 5bc16a39b30..fa79b7cc535 100644 --- 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 index c2926763272..89236c97bf6 100644 --- 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 index 26a81299d9b..4ff73ddfd45 100644 --- 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,10 +300,11 @@ 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 @@ -305,6 +312,7 @@ rollForward w blocks _nodeTip = do . 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 index 7fdb3048512..7946d5adfa6 100644 --- 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 index e0177a95b96..6531190e569 100644 --- 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 index b33587f2c6f..acf7cdd45c9 100644 --- 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 index f9878ff51e7..d2bcc2d5916 100644 --- 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