[ADP-3451] Use a single thread to signal resource changes (#4783)

This PR remove the session level resource change signal for a process level one. This allow changes to the resource coming from the data service to trigger UI updates. - Remove send sse from putResource and loadResource ops - Extend the UILayer to host a resource changes channel - Feed the UILayer channel with changes from the resource via an observer thread ADP-3451
cardano-foundation · Sep 25, 2024 · 0d0e959 · 0d0e959
2 parents a6456c9 + 2b3f154
commit 0d0e959
Show file tree

Hide file tree

Showing 12 changed files with 106 additions and 70 deletions.
diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal
@@ -69,6 +69,7 @@ library
     , delta-types
     , io-classes
     , microlens
+    , mtl
     , OddWord
     , text
 
@@ -79,6 +80,7 @@ library
     Cardano.Wallet.Deposit.IO.Network.Mock
     Cardano.Wallet.Deposit.IO.Network.Type
     Cardano.Wallet.Deposit.IO.Resource
+    Cardano.Wallet.Deposit.IO.Resource.Event
     Cardano.Wallet.Deposit.Pure
     Cardano.Wallet.Deposit.Pure.Balance
     Cardano.Wallet.Deposit.Pure.Submissions

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
@@ -39,7 +39,6 @@ import Cardano.Wallet.Deposit.REST.Wallet.Create
     )
 import Control.Tracer
     ( Tracer
-    , nullTracer
     )
 import Data.Functor
     ( ($>)
@@ -98,7 +97,6 @@ createWalletViaMnemonic
                 tracer
                 boot
                 dir
-                nullTracer
                 (xpubFromMnemonics mnemonics')
                 (fromIntegral users')
 
@@ -129,7 +127,6 @@ createWalletViaXPub
                         tracer
                         boot
                         dir
-                        nullTracer
                         xpub'
                         (fromIntegral users')
             Right Nothing -> pure $ Left "Invalid XPub"

diff --git a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs
@@ -67,7 +67,6 @@ import Cardano.Wallet.Deposit.IO
 import Cardano.Wallet.Deposit.IO.Resource
     ( ErrResourceExists (..)
     , ErrResourceMissing (..)
-    , ResourceStatus
     )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
@@ -286,9 +285,8 @@ loadWallet
     -- ^ Environment for the wallet
     -> FilePath
     -- ^ Path to the wallet database directory
-    -> Tracer IO (ResourceStatus ErrDatabase WalletIO.WalletInstance)
     -> WalletResourceM ()
-loadWallet bootEnv dir trs = do
+loadWallet bootEnv dir = do
     let action :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b)
         action f = findTheDepositWalletOnDisk dir $ \case
             Right wallet ->
@@ -301,7 +299,7 @@ loadWallet bootEnv dir trs = do
     lift
         $ ExceptT
         $ first ErrWalletPresent
-            <$> Resource.putResource action trs resource
+            <$> Resource.putResource action resource
 
 -- | Initialize a new wallet from an 'XPub'.
 initXPubWallet
@@ -311,13 +309,12 @@ initXPubWallet
     -- ^ Environment for the wallet
     -> FilePath
     -- ^ Path to the wallet database directory
-    -> Tracer IO (ResourceStatus ErrDatabase WalletIO.WalletInstance)
     -> XPub
     -- ^ Id of the wallet
     -> Word31
     -- ^ Max number of users ?
     -> WalletResourceM ()
-initXPubWallet tr bootEnv dir trs xpub users = do
+initXPubWallet tr bootEnv dir xpub users = do
     let action :: (WalletIO.WalletInstance -> IO b) -> IO (Either ErrDatabase b)
         action f = createTheDepositWalletOnDisk tr dir xpub users $ \case
             Just wallet -> do
@@ -338,7 +335,7 @@ initXPubWallet tr bootEnv dir trs xpub users = do
     lift
         $ ExceptT
         $ first ErrWalletPresent
-            <$> Resource.putResource action trs resource
+            <$> Resource.putResource action resource
 
 deleteWallet :: FilePath -> WalletResourceM ()
 deleteWallet dir = do

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
@@ -8,14 +8,9 @@ import Prelude
 
 import Cardano.Wallet.Deposit.IO
     ( WalletBootEnv (..)
-    , WalletInstance
-    )
-import Cardano.Wallet.Deposit.IO.Resource
-    ( ResourceStatus
     )
 import Cardano.Wallet.Deposit.REST
-    ( ErrDatabase
-    , WalletResource
+    ( WalletResource
     , loadWallet
     , runWalletResourceM
     , walletExists
@@ -36,17 +31,16 @@ lg tr p x = liftIO $ traceWith tr $ p <> ": " <> show x
 
 loadDepositWalletFromDisk
     :: Tracer IO String
-    -> Tracer IO (ResourceStatus ErrDatabase WalletInstance)
     -> FilePath
     -> WalletBootEnv IO
     -> WalletResource
     -> IO ()
-loadDepositWalletFromDisk tr sttr dir env resource = do
+loadDepositWalletFromDisk tr dir env resource = do
     result <- flip runWalletResourceM resource $ do
         test <- walletExists dir
         when test $ do
             lg tr "Loading wallet from" dir
-            loadWallet env dir sttr
+            loadWallet env dir
             lg tr "Wallet loaded from" dir
     case result of
         Left e -> error $ show e

diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource.hs
@@ -35,17 +35,12 @@ import Control.Concurrent.Class.MonadSTM
     , writeTVar
     )
 import Control.Monad
-    ( join
-    , void
+    ( void
     )
 import Control.Monad.Class.MonadThrow
     ( MonadThrow (..)
     , SomeException
     )
-import Control.Tracer
-    ( Tracer
-    , traceWith
-    )
 
 {-----------------------------------------------------------------------------
     Resource
@@ -78,8 +73,8 @@ instance Functor (ResourceStatus e) where
     fmap _ Closing = Closing
 
 -- | Read the status of a 'Resource'.
-readStatus :: Resource e a -> IO (ResourceStatus e ())
-readStatus resource = void <$> readTVarIO (content resource)
+readStatus :: Resource e a -> STM IO (ResourceStatus e a)
+readStatus resource = readTVar (content resource)
 
 -- | Make a 'Resource' that can be initialized later.
 --
@@ -190,11 +185,10 @@ data ErrResourceExists e a
 putResource
     :: (forall b. (a -> IO b) -> IO (Either e b))
     -- ^ Function to initialize the resource 'a'
-    -> Tracer IO (ResourceStatus e a)
     -> Resource e a
     -- ^ The 'Resource' to initialize.
     -> IO (Either (ErrResourceExists e a) ())
-putResource start trs resource = do
+putResource start resource = do
     forking <- atomically $ do
         ca :: ResourceStatus e a <- readTVar (content resource)
         case ca of
@@ -204,37 +198,31 @@ putResource start trs resource = do
             Open a -> pure $ Left $ ErrAlreadyInitialized a
             Closed -> do
                 writeTVar (content resource) Opening
-                pure $ Right (forkInitialization >> traceWith trs Opening)
+                pure $ Right forkInitialization
             Closing -> pure $ Left ErrAlreadyClosing
     case forking of
         Left e -> pure $ Left e
         Right action -> Right <$> action
   where
     controlInitialization = do
         r <- start run
-        join $ atomically $ case r of
+        atomically $ case r of
             Right (Right ()) -> do
                 writeTVar (content resource) Closed
-                pure $ traceWith trs Closed
             Right (Left (Left e)) -> do
                 writeTVar (content resource) (Vanished e)
-                pure $ traceWith trs (Vanished e)
             Right (Left (Right e)) -> do
                 writeTVar (content resource) (FailedToOpen e)
-                pure $ traceWith trs (FailedToOpen e)
             Left e -> do
                 writeTVar (content resource) (FailedToOpen e)
-                pure $ traceWith trs (FailedToOpen e)
 
     forkInitialization = void $ forkFinally controlInitialization vanish
 
     run a = do
         atomically $ writeTVar (content resource) (Open a)
-        traceWith trs (Open a)
         waitForEndOfLife resource
 
     vanish (Left e) = do
         atomically $ writeTVar (content resource) (Vanished e)
-        traceWith trs (Vanished e)
     vanish (Right _) =
         pure () -- waitForEndOfLife has succeeded
diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Resource/Event.hs
@@ -0,0 +1,48 @@
+module Cardano.Wallet.Deposit.IO.Resource.Event
+    ( onResourceChange
+    ) where
+
+import Prelude
+
+import Cardano.Wallet.Deposit.IO.Resource
+    ( Resource
+    , ResourceStatus (..)
+    , readStatus
+    )
+import Control.Concurrent.Async
+    ( withAsync
+    )
+import Control.Concurrent.Class.MonadSTM
+    ( MonadSTM (..)
+    , atomically
+    )
+import Control.Monad
+    ( void
+    )
+import Control.Monad.Cont
+    ( ContT (..)
+    )
+import Control.Monad.Fix
+    ( fix
+    )
+
+-- | Run an action whenever the status of a 'Resource' changes.
+onResourceChange
+    :: (ResourceStatus e a -> IO ())
+    -> Resource e a
+    -> ContT x IO ()
+onResourceChange f resource = do
+    void $ ContT $ withAsync $ ($ Closed) $ fix $ \loop lastStatus -> do
+        status <- atomically $ do
+            status <- readStatus resource
+            case (status, lastStatus) of
+                (Closed, Closed) -> retry
+                (Opening, Opening) -> retry
+                (Open _a, Open _a') -> retry -- this is something to think about
+                (FailedToOpen _e, FailedToOpen _e') -> retry
+                (Vanished _e, Vanished _e') -> retry
+                (Closing, Closing) -> retry
+                _ -> pure ()
+            pure status
+        f status
+        loop status
diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/RESTSpec.hs
@@ -77,7 +77,7 @@ withInitializedWallet
     -> WalletResourceM a
     -> IO (Either ErrWalletResource a)
 withInitializedWallet dir f = withWallet $ do
-    initXPubWallet nullTracer fakeBootEnv dir nullTracer xpub 0
+    initXPubWallet nullTracer fakeBootEnv dir xpub 0
     letItInitialize
     f
 
@@ -86,7 +86,7 @@ withLoadedWallet
     -> WalletResourceM a
     -> IO (Either ErrWalletResource a)
 withLoadedWallet dir f = withWallet $ do
-    loadWallet fakeBootEnv dir nullTracer
+    loadWallet fakeBootEnv dir
     letItInitialize
     f
 

diff --git a/lib/exe/lib/Cardano/Wallet/Application.hs b/lib/exe/lib/Cardano/Wallet/Application.hs
@@ -181,7 +181,9 @@ import Cardano.Wallet.UI.Common.Html.Pages.Template.Head
     ( PageConfig (..)
     )
 import Cardano.Wallet.UI.Common.Layer
-    ( UILayer
+    ( Push (..)
+    , UILayer
+    , oobMessages
     , sourceOfNewTip
     )
 import Control.Exception.Extra
@@ -203,7 +205,6 @@ import Control.Monad.Trans.Except
     )
 import Control.Tracer
     ( Tracer (..)
-    , nullTracer
     , traceWith
     )
 import Data.Function
@@ -263,6 +264,7 @@ import qualified Cardano.Wallet.Api.Http.Shelley.Server as Server
 import qualified Cardano.Wallet.DB.Layer as Sqlite
 import qualified Cardano.Wallet.Deposit.HTTP.Server as Deposit
 import qualified Cardano.Wallet.Deposit.HTTP.Types.API as Deposit
+import qualified Cardano.Wallet.Deposit.IO.Resource.Event as REST
 import qualified Cardano.Wallet.UI.Common.Layer as Ui
 import qualified Cardano.Wallet.UI.Deposit.API as DepositUi
 import qualified Cardano.Wallet.UI.Deposit.Server as DepositUi
@@ -419,13 +421,19 @@ serveWallet
                             resource <- ContT withResource
                             liftIO
                                 $ loadDepositWalletFromDisk
-                                    (DepositApplicationLog
-                                        >$< applicationTracer)
-                                    nullTracer
+                                    ( DepositApplicationLog
+                                        >$< applicationTracer
+                                    )
                                     databaseDir'
                                     fakeBootEnv
                                     resource
                             ui <- Ui.withUILayer 1 resource
+                            REST.onResourceChange
+                                ( \_ -> do
+                                    traceWith (oobMessages ui)
+                                        $ Push "wallet"
+                                )
+                                resource
                             sourceOfNewTip netLayer ui
                             let uiService =
                                     startDepositUiServer
@@ -456,9 +464,9 @@ serveWallet
                                         resource <- ContT withResource
                                         liftIO
                                             $ loadDepositWalletFromDisk
-                                                (DepositApplicationLog
-                                                    >$< applicationTracer)
-                                                nullTracer
+                                                ( DepositApplicationLog
+                                                    >$< applicationTracer
+                                                )
                                                 databaseDir'
                                                 fakeBootEnv
                                                 resource

diff --git a/lib/ui/cardano-wallet-ui.cabal b/lib/ui/cardano-wallet-ui.cabal
@@ -115,6 +115,7 @@ library
     , random
     , servant
     , servant-server
+    , stm
     , string-interpolate
     , text
     , text-class