From b7dbfd223f63ec45e8f04d1d1589988aac3b2c05 Mon Sep 17 00:00:00 2001 From: prolic Date: Mon, 11 Nov 2024 17:31:49 -0300 Subject: [PATCH] QML reads in new treads UI changes and does max 10 updates per second --- src/EffectfulQML.hs | 90 +++++++++++++++++++++-------------- src/Futr.hs | 17 ++----- src/Main.hs | 11 +++-- src/Presentation/RelayMgmt.hs | 6 ++- src/Types.hs | 3 -- src/UI.hs | 5 +- 6 files changed, 72 insertions(+), 60 deletions(-) diff --git a/src/EffectfulQML.hs b/src/EffectfulQML.hs index b932595..94ca5ec 100644 --- a/src/EffectfulQML.hs +++ b/src/EffectfulQML.hs @@ -4,21 +4,39 @@ module EffectfulQML where -import Control.Monad (forM_, when) +import Control.Monad (forM_, void, when) import Effectful +import Effectful.Concurrent +import Effectful.Concurrent.Async (async) +import Effectful.Concurrent.STM (TQueue, atomically, flushTQueue, newTQueueIO, readTQueue, writeTQueue) import Effectful.Dispatch.Dynamic (EffectHandler, interpret) import Effectful.State.Static.Shared (State, evalState, get, gets, put) import Effectful.TH import Graphics.QML qualified as QML import Logging -import Types (AppState(..), UIReferences(..), UIUpdates(..)) +import Types (AppState(..), UIReferences(..), UIUpdates(..), emptyUpdates) + +-- | Effectful QML state. data EffectfulQMLState = EffectfulQMLState { signalKey :: Maybe (QML.SignalKey (IO ())) , rootObjRef :: Maybe (QML.ObjRef ()) + , uiRefs :: UIReferences + , queue :: Maybe (TQueue UIUpdates) } + +-- | Initial effectful QML state. +initialEffectfulQMLState :: EffectfulQMLState +initialEffectfulQMLState = EffectfulQMLState Nothing Nothing initialUIRefs Nothing + + +-- | Initial UI references. +initialUIRefs :: UIReferences +initialUIRefs = UIReferences Nothing Nothing Nothing Nothing Nothing + + -- | Define the effects for QML operations. data EffectfulQML :: Effect where RunEngineLoop :: QML.EngineConfig -> QML.SignalKey (IO ()) -> QML.ObjRef () -> EffectfulQML m () @@ -33,51 +51,51 @@ type instance DispatchOf EffectfulQML = Dynamic makeEffect ''EffectfulQML + -- | Handler for the QML effects. runEffectfulQML - :: (IOE :> es, Logging :> es, State AppState :> es) - => Eff (EffectfulQML : State EffectfulQMLState : es) a + :: (IOE :> es, Concurrent :> es, Logging :> es, State EffectfulQMLState :> es, State AppState :> es) + => Eff (EffectfulQML : es) a -> Eff es a -runEffectfulQML action = evalState (EffectfulQMLState Nothing Nothing) $ interpret handleEffectfulQML action - where - handleEffectfulQML - :: (IOE :> es, Logging :> es, State AppState :> es) - => EffectHandler EffectfulQML (State EffectfulQMLState : es) - handleEffectfulQML _ = \case - RunEngineLoop config changeKey ctx -> do - put $ EffectfulQMLState (Just changeKey) (Just ctx) +runEffectfulQML = interpret $ \_ -> \case + RunEngineLoop config changeKey ctx -> do + q <- newTQueueIO + put $ EffectfulQMLState (Just changeKey) (Just ctx) initialUIRefs (Just q) + void $ async $ do + uiUpdates <- atomically $ readTQueue q + moreUpdates <- atomically $ flushTQueue q + let combinedUpdates = uiUpdates <> mconcat moreUpdates + + refs <- gets uiRefs + + when (profilesChanged combinedUpdates) $ forM_ (profileObjRef refs) (liftIO . QML.fireSignal changeKey) + when (followsChanged combinedUpdates) $ forM_ (followsObjRef refs) (liftIO . QML.fireSignal changeKey) + when (chatsChanged combinedUpdates) $ forM_ (chatObjRef refs) (liftIO . QML.fireSignal changeKey) + when (dmRelaysChanged combinedUpdates) $ forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal changeKey) + when (generalRelaysChanged combinedUpdates) $ forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal changeKey) + + threadDelay 100000 -- max 10 UI updates per second + liftIO $ QML.runEngineLoop config - CreateSignalKey -> liftIO $ QML.newSignalKey + CreateSignalKey -> liftIO $ QML.newSignalKey - FireSignal obj -> do + FireSignal obj -> do st <- get case signalKey st of Just key -> liftIO $ QML.fireSignal key obj Nothing -> logError "No signal key available" - NotifyRelayStatus -> do + NotifyRelayStatus -> do st <- get - refs <- gets @AppState uiRefs - case signalKey st of - Just key -> do - forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal key) - forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal key) - Nothing -> logError "No signal key available" + case queue st of + Just q -> do + let updates = emptyUpdates { dmRelaysChanged = True, generalRelaysChanged = True } + atomically $ writeTQueue q updates + Nothing -> logError "No queue available" - Notify u -> do + Notify u -> do st <- get - refs <- gets @AppState uiRefs - case signalKey st of - Just key -> do - when (profilesChanged u) $ forM_ (profileObjRef refs) (liftIO . QML.fireSignal key) - when (followsChanged u) $ forM_ (followsObjRef refs) (liftIO . QML.fireSignal key) - when (chatsChanged u) $ forM_ (chatObjRef refs) (liftIO . QML.fireSignal key) - when (dmRelaysChanged u) $ forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal key) - when (generalRelaysChanged u) $ forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal key) - -- there is no obj ref for publish status - --when (publishStatusChanged u) $ forM_ (publishStatusObjRef refs) (liftIO . QML.fireSignal key) - -- there is no obj ref for notices - --when (noticesChanged u) $ forM_ (noticesObjRef refs) (liftIO . QML.fireSignal key) - Nothing -> logError "No signal key available" - + case queue st of + Just q -> atomically $ writeTQueue q u + Nothing -> logError "No queue available" diff --git a/src/Futr.hs b/src/Futr.hs index c5ae85c..b6a4e3a 100644 --- a/src/Futr.hs +++ b/src/Futr.hs @@ -90,6 +90,7 @@ type FutrEff es = ( State AppState :> es , Publisher :> es , State PKeyMgmt.KeyMgmtState :> es , State RelayPoolState :> es + , State EffectfulQMLState :> es , GiftWrap :> es , EffectfulQML :> es , Logging :> es @@ -129,10 +130,7 @@ runFutr = interpret $ \_ -> \case case bech32ToPubKeyXO npub' of Just pk -> do modify @AppState $ \st -> st { currentProfile = Just pk } - refs <- gets @AppState uiRefs - case profileObjRef refs of - Just obj' -> fireSignal obj' - Nothing -> return () + notify $ emptyUpdates { profilesChanged = True } Nothing -> do logError $ "Invalid npub, cannot set current profile: " <> npub' return () @@ -147,9 +145,7 @@ runFutr = interpret $ \_ -> \case let newFollow = Follow pubKeyXO Nothing Nothing let newFollows = newFollow : currentFollows modify $ \st' -> st' { follows = Map.insert userPK newFollows (follows st') } - -- Notify follows UI component - refs <- gets @AppState uiRefs - forM_ (followsObjRef refs) fireSignal + notify $ emptyUpdates { followsChanged = True } sendFollowListEvent Nothing -> return () @@ -162,9 +158,7 @@ runFutr = interpret $ \_ -> \case let currentFollows = Map.findWithDefault [] userPK (follows st) let newFollows = filter (\follow -> pubkey follow /= pubKeyXO) currentFollows modify $ \st' -> st' { follows = Map.insert userPK newFollows (follows st') } - -- Notify follows UI component - refs <- gets @AppState uiRefs - forM_ (followsObjRef refs) fireSignal + notify $ emptyUpdates { followsChanged = True } sendFollowListEvent Nothing -> return () @@ -176,8 +170,7 @@ runFutr = interpret $ \_ -> \case _ -> return () modify $ \st' -> st' { currentChatRecipient = (Just [pubKeyXO], Nothing) } - refs <- gets @AppState uiRefs - forM_ (chatObjRef refs) fireSignal -- Notify chat UI component + notify $ emptyUpdates { chatsChanged = True } SendMessage input -> do st <- get @AppState diff --git a/src/Main.hs b/src/Main.hs index 7c3081c..4209c2c 100755 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,11 +3,11 @@ module Main where import Effectful import Effectful.Concurrent (runConcurrent) import Effectful.FileSystem (runFileSystem) -import Effectful.State.Static.Shared (State,evalState) -import EffectfulQML +import Effectful.State.Static.Shared (State, evalState) import Graphics.QML qualified as QML import System.Environment (setEnv) +import EffectfulQML import Futr qualified as Futr import Logging (runLoggingStdout) import Nostr @@ -38,13 +38,14 @@ main = do runEff . runLoggingStdout + . runConcurrent -- state related . withInitialState -- app related + . evalState initialEffectfulQMLState . runEffectfulQML . runFileSystem . runUtil - . runConcurrent -- nostr related . runNostr . KeyMgmt.runKeyMgmt @@ -81,7 +82,7 @@ withInitialState : State AppState : es) a -> Eff es a -withInitialState = - evalState Types.initialState +withInitialState + = evalState Types.initialState . evalState KeyMgmt.initialState . evalState Types.initialRelayPoolState diff --git a/src/Presentation/RelayMgmt.hs b/src/Presentation/RelayMgmt.hs index 61123b6..6559f89 100644 --- a/src/Presentation/RelayMgmt.hs +++ b/src/Presentation/RelayMgmt.hs @@ -17,6 +17,7 @@ import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH import Graphics.QML hiding (fireSignal, runEngineLoop) +import EffectfulQML (EffectfulQMLState(..)) import Nostr.Keys (keyPairToPubKeyXO) import Nostr.RelayPool import Nostr.Types hiding (displayName, picture) @@ -30,6 +31,7 @@ data RelayType = DMRelays | InboxRelays | OutboxRelays type RelayMgmgtUIEff es = ( State AppState :> es , State RelayPoolState :> es + , State EffectfulQMLState :> es , RelayPool :> es , Concurrent :> es , Util :> es @@ -122,7 +124,7 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action contextClass <- newClass [ defPropertySigRO' "dmRelays" changeKey $ \obj -> do - runE $ modify @AppState $ \s -> s { + runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { dmRelaysObjRef = Just obj } } appState <- runE $ get @AppState @@ -134,7 +136,7 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action mapM (\(relay, _status) -> getPoolObject dmRelayPool (getUri relay)) relaysWithStatus, defPropertySigRO' "generalRelays" changeKey $ \obj -> do - runE $ modify @AppState $ \s -> s { + runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { generalRelaysObjRef = Just obj } } appState <- runE $ get @AppState diff --git a/src/Types.hs b/src/Types.hs index 3f63f8f..42c5c7a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -148,8 +148,6 @@ data AppState = AppState -- UI state , currentChatRecipient :: (Maybe [PubKeyXO], Maybe SubscriptionId) , currentProfile :: Maybe PubKeyXO - -- QML References - , uiRefs :: UIReferences } -- | UI object references grouped together @@ -182,5 +180,4 @@ initialState = AppState , follows = Map.empty , currentChatRecipient = (Nothing, Nothing) , currentProfile = Nothing - , uiRefs = UIReferences Nothing Nothing Nothing Nothing Nothing } diff --git a/src/UI.hs b/src/UI.hs index 941aef1..56d803b 100644 --- a/src/UI.hs +++ b/src/UI.hs @@ -20,6 +20,7 @@ import EffectfulQML import Graphics.QML hiding (fireSignal, runEngineLoop) import Text.Read (readMaybe) +import EffectfulQML (EffectfulQMLState(..)) import Logging import Nostr.Bech32 import Nostr.Event @@ -185,7 +186,7 @@ runUI = interpret $ \_ -> \case defPropertyConst' "currentProfile" (\_ -> do profileObj <- newObject profileClass () - runE $ modify @AppState $ \st -> st { uiRefs = (uiRefs st) { profileObjRef = Just profileObj } } + runE $ modify @EffectfulQMLState $ \st -> st { uiRefs = (uiRefs st) { profileObjRef = Just profileObj } } return profileObj ), @@ -253,7 +254,7 @@ runUI = interpret $ \_ -> \case Nothing -> return [], defPropertySigRO' "messages" changeKey' $ \obj -> do - runE $ modify @AppState $ \s -> s { uiRefs = (uiRefs s) { chatObjRef = Just obj } } + runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { chatObjRef = Just obj } } st <- runE $ get @AppState case currentChatRecipient st of (Just recipient, _) -> do