From 7f51c2ee67507dcb01d2274aa8f648e37267581c Mon Sep 17 00:00:00 2001 From: prolic Date: Tue, 29 Oct 2024 21:18:25 -0300 Subject: [PATCH] cleanup --- cabal.project | 6 +- src/Futr.hs | 6 +- src/Nostr/OutboxModel.hs | 12 +- src/Nostr/PublishManager.hs | 38 +++--- src/Nostr/RelayPool.hs | 224 +++++++++++++++++----------------- src/Nostr/Subscription.hs | 4 +- src/Nostr/WebSocket.hs | 10 +- src/Presentation/RelayMgmt.hs | 9 +- src/Types.hs | 3 +- 9 files changed, 158 insertions(+), 154 deletions(-) diff --git a/cabal.project b/cabal.project index b559c26..9a09821 100755 --- a/cabal.project +++ b/cabal.project @@ -1,13 +1,9 @@ packages: ./ + ../HsQML tests: True source-repository-package type: git location: https://github.com/prolic/secp256k1-schnorr tag: 10555f6d6cdba34e60799d915ac3e60a01c76d46 - -source-repository-package - type: git - location: https://github.com/prolic/HsQML/ - tag: e7fe83f9cc535c66c423d5402d3351c774a5bc2c diff --git a/src/Futr.hs b/src/Futr.hs index a8eca2d..ee01821 100644 --- a/src/Futr.hs +++ b/src/Futr.hs @@ -4,12 +4,12 @@ module Futr where -import Control.Monad (forM, forM_, void, unless, when) +import Control.Monad (forM, forM_, void, unless) import Data.Aeson (ToJSON, pairs, toEncoding, (.=)) import Data.Maybe (catMaybes, listToMaybe) import Data.Map.Strict qualified as Map import Data.Proxy (Proxy(..)) -import Data.Text (Text, isPrefixOf, pack) +import Data.Text (Text, isPrefixOf) import Data.Typeable (Typeable) import Effectful import Effectful.Concurrent @@ -258,7 +258,7 @@ parseNprofileOrNpub input = loginWithAccount :: FutrEff es => ObjRef () -> PKeyMgmt.Account -> Eff es Bool loginWithAccount obj a = do modify @AppState $ \s -> s { keyPair = Just (secKeyToKeyPair $ PKeyMgmt.nsec a) } - let (rs, t) = PKeyMgmt.relays a + let (rs, _) = PKeyMgmt.relays a -- add general relays --modify @AppState $ \st -> st { generalRelays = (rs, t) } -- add all relays to the relay pool diff --git a/src/Nostr/OutboxModel.hs b/src/Nostr/OutboxModel.hs index 45f6807..6d4c3f7 100644 --- a/src/Nostr/OutboxModel.hs +++ b/src/Nostr/OutboxModel.hs @@ -2,8 +2,7 @@ module Nostr.OutboxModel where -import Control.Monad (forM, forM_, void) -import Data.List (find) +import Control.Monad (forM, void) import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes) import Data.Text (Text) @@ -102,19 +101,19 @@ runOutboxModel = interpret $ \_ -> \case modify $ \st -> st { publishStatus = Publishing event : publishStatus st } void $ async $ do relays <- gets $ \st -> Map.findWithDefault ([], 0) pk (outboxes st) - publishToRelays event pk High relays + publishToRelays event High relays SendToInboxes event pk -> do modify $ \st -> st { publishStatus = Publishing event : publishStatus st } void $ async $ do relays <- gets $ \st -> Map.findWithDefault ([], 0) pk (inboxes st) - publishToRelays event pk Critical relays + publishToRelays event Critical relays SendToDMRelays event pk -> do modify $ \st -> st { publishStatus = Publishing event : publishStatus st } void $ async $ do relays <- gets $ \st -> Map.findWithDefault ([], 0) pk (dmRelays st) - publishToRelays event pk Critical relays + publishToRelays event Critical relays -- Helper functions @@ -158,11 +157,10 @@ collectResponseWithTimeout event queue endTime = do -- Helper function for common publish logic publishToRelays :: OutboxModelEff es => Event - -> PubKeyXO -> RelayPriority -> ([RelayURI], Int) -- relay list and timestamp -> Eff es () -publishToRelays event pk priority (relays, _) = do +publishToRelays event priority (relays, _) = do subs <- forM relays \relay -> do requestConnection relay priority RP.sendEvent event [relay] diff --git a/src/Nostr/PublishManager.hs b/src/Nostr/PublishManager.hs index 15d1ea9..5036e05 100644 --- a/src/Nostr/PublishManager.hs +++ b/src/Nostr/PublishManager.hs @@ -4,22 +4,20 @@ module Nostr.PublishManager where -import Control.Monad (forever, forM_, void, when) +import Control.Monad (forM_) import Data.List (find) import Data.Map.Strict qualified as Map -import Data.Text (Text, pack) +import Data.Text (Text) import Data.Either (isRight) import Data.Aeson import Effectful -import Effectful.Concurrent (Concurrent, threadDelay) -import Effectful.Concurrent.Async (async) import Effectful.Dispatch.Dynamic import Effectful.State.Static.Shared import Effectful.TH import GHC.Generics (Generic) import Logging -import Nostr.Keys (PubKeyXO, byteStringToHex) +import Nostr.Keys (byteStringToHex) import Nostr.Types (Event(..), EventId(..), RelayURI) import Nostr.Util import Types (PublishStatus(..)) @@ -60,7 +58,7 @@ type instance DispatchOf PublishManager = Dynamic makeEffect ''PublishManager -type PublishManagerEff es = (State PublishManagerState :> es, Logging :> es, Util :> es, Concurrent :> es) +type PublishManagerEff es = (State PublishManagerState :> es, Logging :> es, Util :> es) -- | State for publish manager data PublishManagerState = PublishManagerState @@ -149,20 +147,20 @@ runPublishManager = interpret $ \_ -> \case GetMetrics relay -> gets $ \st -> Map.findWithDefault initialMetrics relay (metrics st) - TrackSubscription subId relay -> do + TrackSubscription subId' relay -> do now <- getCurrentTime modify $ \st -> st - { activeSubscriptions = Map.insert subId - (SubscriptionInfo subId now relay) + { activeSubscriptions = Map.insert subId' + (SubscriptionInfo subId' now relay) (activeSubscriptions st) } - UpdateSubscriptionActivity subId -> do + UpdateSubscriptionActivity subId' -> do now <- getCurrentTime modify $ \st -> st - { activeSubscriptions = Map.adjust - (\info -> info { lastActivity = now }) - subId + { activeSubscriptions = Map.adjust + (\info -> info { lastActivity = now }) + subId' (activeSubscriptions st) } @@ -170,13 +168,13 @@ runPublishManager = interpret $ \_ -> \case now <- getCurrentTime st <- get let cutoff = now - timeout - let (stale, active) = Map.partition - (\info -> lastActivity info < cutoff) + let (stale, active) = Map.partition + (\info -> lastActivity info < cutoff) (activeSubscriptions st) -- Log stale subscriptions being cleaned up - forM_ (Map.toList stale) $ \(subId, info) -> - logInfo $ "Cleaning up stale subscription " <> subId + forM_ (Map.toList stale) $ \(subId', info) -> + logInfo $ "Cleaning up stale subscription " <> subId' <> " for relay " <> relayUri info modify $ \st' -> st' { activeSubscriptions = active } @@ -235,8 +233,8 @@ notMatchingEventId eid status = case status of -- Add helper isStaleStatus :: Int -> PublishStatus -> Bool -isStaleStatus cutoff = \case +isStaleStatus cutoff status = case status of Publishing _ -> True -- Always clean up stuck "publishing" status PublishSuccess _ -> False -- Keep successful publishes - PublishFailed _ _ -> True -- Clean up failed publishes - PublishPartial _ _ -> True -- Clean up partial publishes + PublishFailed e _ -> createdAt e < cutoff -- Clean up old failed publishes + PublishPartial e _ -> createdAt e < cutoff -- Clean up old partial publishes diff --git a/src/Nostr/RelayPool.hs b/src/Nostr/RelayPool.hs index 4416484..5550077 100644 --- a/src/Nostr/RelayPool.hs +++ b/src/Nostr/RelayPool.hs @@ -10,22 +10,20 @@ import Data.Text qualified as T import Effectful import Effectful.Concurrent (Concurrent, threadDelay) import Effectful.Concurrent.Async (async) -import Effectful.Concurrent.STM (TChan, TQueue, atomically, newTChanIO, newTQueueIO, writeTChan) +import Effectful.Concurrent.STM (TQueue, atomically, newTChanIO, newTQueueIO, writeTChan) import Effectful.Dispatch.Dynamic (EffectHandler, interpret) -import Effectful.State.Static.Shared (State, evalState, get, gets, modify) +import Effectful.State.Static.Shared (State, evalState, get, modify) import Effectful.TH import Logging import Nostr -import Nostr.Event (createFollowList) -import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) import Nostr.Subscription import Nostr.WebSocket (WebSocket, WebSocketState(..), RelayConnectionState(..), ConnectionState(..), runClient) import Nostr.Types import Nostr.Util -import Types (AppState(..), ConnectionError(..), Follow(..), FollowModel(..), +import Types (AppState(..), ConnectionError(..), RelayPoolState(..), RelayData(..), initialRelayPoolState, - RelayState(..), RelayPriority(..), SubscriptionDetails(..)) + RelayState(..), SubscriptionDetails(..)) -- | Effect for handling RelayPool operations. data RelayPool :: Effect where @@ -66,9 +64,9 @@ type RelayPoolEff es = -- Add new handler handleConnectionError :: RelayPoolEff es => RelayURI -> ConnectionError -> Eff es () -handleConnectionError uri err = do +handleConnectionError uri' err = do currentTime <- getCurrentTime - logError $ "Connection failed to " <> uri <> ": " <> connecionErrorToText err + logError $ "Connection failed to " <> uri' <> ": " <> connecionErrorToText err modify @RelayPoolState $ \st -> st { activeConnections = Map.adjust @@ -77,11 +75,11 @@ handleConnectionError uri err = do , connectionAttempts = connectionAttempts rd + 1 , connectionState = RelayFailed (connecionErrorToText err) }) - uri + uri' (activeConnections st) } - when (shouldRetry err) $ scheduleReconnect uri + when (shouldRetry err) $ scheduleReconnect uri' where shouldRetry = \case TimeoutError -> True @@ -91,19 +89,19 @@ handleConnectionError uri err = do -- Add reconnection logic scheduleReconnect :: RelayPoolEff es => RelayURI -> Eff es () -scheduleReconnect uri = void $ async $ do +scheduleReconnect uri' = void $ async $ do threadDelay (5 * 1000000) -- Wait 5 seconds st <- get @RelayPoolState - case Map.lookup uri (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just rd | shouldAttemptReconnect rd -> do - updateRelayState uri (RelayRetrying $ connectionAttempts rd) - void $ tryConnect uri rd + updateRelayState uri' (RelayRetrying $ connectionAttempts rd) + void $ tryConnect uri' rd _ -> return () isDisconnected :: RelayURI -> RelayPoolState -> Bool -isDisconnected uri st = - case Map.lookup uri (activeConnections st) of +isDisconnected uri' st = + case Map.lookup uri' (activeConnections st) of Nothing -> True Just rd -> case lastError rd of Just _ -> True @@ -112,50 +110,50 @@ isDisconnected uri st = -- Add this helper function tryConnect :: RelayPoolEff es => RelayURI -> RelayData -> Eff es Bool -tryConnect relayURI' relayData = do - updateConnectionState relayURI' Connecting - let relay = Relay relayURI' (relayInfo relayData) +tryConnect uri' relayData = do + updateConnectionState uri' Connecting + let relay = Relay uri' (relayInfo relayData) result <- runClient relay (requestChannel relayData) (responseQueue relayData) case result of Left e -> do let err = ConnectionFailed (T.pack $ show e) - handleConnectionError relayURI' err - updateConnectionState relayURI' Disconnected + handleConnectionError uri' err + updateConnectionState uri' Disconnected return False Right _ -> do - logInfo $ "Successfully connected to " <> relayURI' - updateConnectionState relayURI' Connected + logInfo $ "Successfully connected to " <> uri' + updateConnectionState uri' Connected return True -- Add helper to update connection state updateConnectionState :: RelayPoolEff es => RelayURI -> ConnectionState -> Eff es () -updateConnectionState uri state = do +updateConnectionState uri' state = do wsState <- get @WebSocketState - if Map.member uri (connections wsState) + if Map.member uri' (connections wsState) then modify @WebSocketState $ \ws -> - ws { connections = Map.adjust - (\connState -> connState { connectionStatus = state }) - uri - (connections ws) + ws { connections = Map.adjust + (\connState -> connState { connectionStatus = state }) + uri' + (connections ws) } - else logWarning $ "Cannot update connection state for unknown relay: " <> uri + else logWarning $ "Cannot update connection state for unknown relay: " <> uri' -- Add helper to check connection status getConnectionStatus :: RelayPoolEff es => RelayURI -> Eff es (Maybe ConnectionState) -getConnectionStatus uri = do +getConnectionStatus uri' = do wsState <- get @WebSocketState - return $ connectionStatus <$> Map.lookup uri (connections wsState) + return $ connectionStatus <$> Map.lookup uri' (connections wsState) -- Add helper for subscription management updateSubscriptions :: RelayPoolEff es => RelayURI -> ([SubscriptionId] -> [SubscriptionId]) -> Eff es () -updateSubscriptions uri f = +updateSubscriptions uri' f = modify @RelayPoolState $ \st -> st { activeConnections = Map.adjust - (\rd -> rd { subscriptions = f (subscriptions rd) }) - uri + (\rd -> rd { subscriptions = f (subscriptions rd) }) + uri' (activeConnections st) } @@ -168,13 +166,13 @@ withSubscription subId' action = do st <- get @RelayPoolState let maybeRelayURI = findSubscriptionRelay st subId' case maybeRelayURI of - Just uri -> do - case Map.lookup uri (activeConnections st) of + Just uri' -> do + case Map.lookup uri' (activeConnections st) of Just relayData -> do - result <- action uri relayData + result <- action uri' relayData return (Just result) Nothing -> do - handleRelayError uri $ StateError "No relay data found" + handleRelayError uri' $ StateError "No relay data found" return Nothing Nothing -> do logWarning $ "No relay found for subscription: " <> subId' @@ -188,11 +186,11 @@ data RelayPoolError | StateError Text handleRelayError :: RelayPoolEff es => RelayURI -> RelayPoolError -> Eff es () -handleRelayError uri err = do - logError $ "Relay error for " <> uri <> ": " <> relayPoolErrorToText err +handleRelayError uri' err = do + logError $ "Relay error for " <> uri' <> ": " <> relayPoolErrorToText err case err of - ConnectionError e -> do - updateRelayState uri RelayDisconnected + ConnectionError _ -> do + updateRelayState uri' RelayDisconnected SubscriptionError msg -> logWarning $ "Subscription error: " <> msg StateError msg -> @@ -210,9 +208,9 @@ runRelayPool action = evalState initialRelayPoolState $ interpret handleRelayPoo handleRelayPool _ = \case AddRelay relay -> do st <- get @RelayPoolState - let relayURI' = uri relay + let uri' = uri relay existingActiveConnections = activeConnections st - unless (Map.member relayURI' existingActiveConnections) do + unless (Map.member uri' existingActiveConnections) do reqChan <- newTChanIO resQueue <- newTQueueIO now <- getCurrentTime @@ -228,41 +226,41 @@ runRelayPool action = evalState initialRelayPoolState $ interpret handleRelayPoo , notices = [] } modify @RelayPoolState $ \st' -> - st' { activeConnections = Map.insert relayURI' newRelayData (activeConnections st') } + st' { activeConnections = Map.insert uri' newRelayData (activeConnections st') } modify @WebSocketState $ \wsState -> - wsState { connections = Map.insert relayURI' (RelayConnectionState Disconnected 0) (connections wsState) } + wsState { connections = Map.insert uri' (RelayConnectionState Disconnected 0) (connections wsState) } - RemoveRelay relayURI' -> do + RemoveRelay uri' -> do st <- get @RelayPoolState -- Disconnect if connected - case Map.lookup relayURI' (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> do atomically $ writeTChan (requestChannel relayData) Nostr.Types.Disconnect - updateConnectionState relayURI' Disconnected + updateConnectionState uri' Disconnected Nothing -> return () -- Remove from both states modify @RelayPoolState $ \s -> - s { activeConnections = Map.delete relayURI' (activeConnections s) } + s { activeConnections = Map.delete uri' (activeConnections s) } modify @WebSocketState $ \s -> - s { connections = Map.delete relayURI' (connections s) } + s { connections = Map.delete uri' (connections s) } - Connect relayURI' -> do + Connect uri' -> do st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> do - updateRelayState relayURI' RelayConnecting - result <- tryConnect relayURI' relayData + updateRelayState uri' RelayConnecting + result <- tryConnect uri' relayData when (not result) $ - updateRelayState relayURI' RelayDisconnected + updateRelayState uri' RelayDisconnected return result Nothing -> return False - Nostr.RelayPool.Disconnect relayURI' -> do + Nostr.RelayPool.Disconnect uri' -> do st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> do atomically $ writeTChan (requestChannel relayData) Nostr.Types.Disconnect - updateConnectionState relayURI' Disconnected + updateConnectionState uri' Disconnected Nothing -> return () DisconnectAll -> do @@ -273,40 +271,40 @@ runRelayPool action = evalState initialRelayPoolState $ interpret handleRelayPoo Nostr.RelayPool.SendEvent event rs -> do st <- get @RelayPoolState - forM_ rs $ \relayURI' -> do - case Map.lookup relayURI' (activeConnections st) of + forM_ rs $ \uri' -> do + case Map.lookup uri' (activeConnections st) of Just relayData -> atomically $ writeTChan (requestChannel relayData) (Nostr.Types.SendEvent event) - Nothing -> logWarning $ "No channel found for relay: " <> relayURI' + Nothing -> logWarning $ "No channel found for relay: " <> uri' GetRelays -> do st <- get @RelayPoolState wst <- get @WebSocketState - relayInfo' <- forM (Map.toList $ activeConnections st) $ \(relayURI', relayData) -> do - let connStatus = case Map.lookup relayURI' (connections wst) of + relayInfo' <- forM (Map.toList $ activeConnections st) $ \(uri', relayData) -> do + let connStatus = case Map.lookup uri' (connections wst) of Nothing -> RelayDisconnected Just connState -> case connectionStatus connState of Connected -> RelayConnected Disconnected -> RelayDisconnected Connecting -> RelayConnecting - return (Relay relayURI' (relayInfo relayData), connStatus) + return (Relay uri' (relayInfo relayData), connStatus) return relayInfo' - GetRelayInfo relayURI' -> do + GetRelayInfo uri' -> do st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> return $ Just relayData Nothing -> return Nothing - StartSubscription relayURI' filters' -> do + StartSubscription uri' filters' -> do st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of - Just relayData -> createSubscription relayURI' filters' relayData + case Map.lookup uri' (activeConnections st) of + Just relayData -> createSubscription uri' filters' relayData _ -> return Nothing StopSubscription subId' -> do - result <- withSubscription subId' $ \relayURI' relayData -> do + result <- withSubscription subId' $ \uri' relayData -> do atomically $ writeTChan (requestChannel relayData) (Close subId') - updateSubscriptions relayURI' (filter (/= subId')) + updateSubscriptions uri' (filter (/= subId')) -- Remove subscription details modify @RelayPoolState $ \s -> s { activeSubscriptions = Map.delete subId' (activeSubscriptions s) @@ -316,31 +314,31 @@ runRelayPool action = evalState initialRelayPoolState $ interpret handleRelayPoo Just _ -> return () Nothing -> return () - UnsubscribeAllSubscriptionsFromRelay relayURI' -> do + UnsubscribeAllSubscriptionsFromRelay uri' -> do st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> do forM_ (subscriptions relayData) $ \subId' -> atomically $ writeTChan (requestChannel relayData) (Close subId') - updateSubscriptions relayURI' (const []) - Nothing -> logError $ "No channel found for relay: " <> relayURI' + updateSubscriptions uri' (const []) + Nothing -> logError $ "No channel found for relay: " <> uri' - ResubscribeAll uri -> do + ResubscribeAll uri' -> do st <- get @RelayPoolState - case Map.lookup uri (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> do - forM_ (subscriptions relayData) $ \subId -> do - case findSubscriptionFilters st subId of - Just filters -> do - void $ createSubscription uri filters relayData + forM_ (subscriptions relayData) $ \subId' -> do + case findSubscriptionFilters st subId' of + Just filters' -> do + void $ createSubscription uri' filters' relayData Nothing -> - logWarning $ "No filters found for subscription: " <> subId + logWarning $ "No filters found for subscription: " <> subId' Nothing -> - logWarning $ "No relay data found for URI: " <> uri + logWarning $ "No relay data found for URI: " <> uri' -- Add these helper functions updateRelayState :: RelayPoolEff es => RelayURI -> RelayState -> Eff es () -updateRelayState uri state = do +updateRelayState uri' state = do -- Update WebSocket state let wsState = case state of RelayConnected -> Connected @@ -348,58 +346,58 @@ updateRelayState uri state = do RelayConnecting -> Connecting _ -> Disconnected modify @WebSocketState $ \st -> - st { connections = Map.insert uri + st { connections = Map.insert uri' (RelayConnectionState wsState 0) (connections st) } -- Add connection lifecycle management manageConnection :: RelayPoolEff es => RelayURI -> Eff es () -manageConnection uri = do +manageConnection uri' = do st <- get @RelayPoolState - case Map.lookup uri (activeConnections st) of + case Map.lookup uri' (activeConnections st) of Just relayData -> do -- Check connection health - status <- getConnectionStatus uri + status <- getConnectionStatus uri' case status of Just Connected -> - updateLastActivity uri + updateLastActivity uri' _ -> do - handleReconnect uri relayData + handleReconnect uri' relayData Nothing -> - handleRelayError uri $ StateError "No connection data found" + handleRelayError uri' $ StateError "No connection data found" -- Add helper to update last activity updateLastActivity :: RelayPoolEff es => RelayURI -> Eff es () -updateLastActivity uri = do +updateLastActivity uri' = do currentTime <- getCurrentTime modify @RelayPoolState $ \st -> st { activeConnections = Map.adjust (\rd -> rd { lastActivity = currentTime , lastError = Nothing -- Clear any previous errors }) - uri + uri' (activeConnections st) } -- Update handleReconnect to use RelayData handleReconnect :: RelayPoolEff es => RelayURI -> RelayData -> Eff es () -handleReconnect uri relayData = do +handleReconnect uri' relayData = do wsState <- get @WebSocketState - case Map.lookup uri (connections wsState) of + case Map.lookup uri' (connections wsState) of Just connState -> do let retries = connectionRetries connState when (retries < 3) $ do -- Max retry attempts -- Increment retry count first modify @WebSocketState $ \ws -> - ws { connections = Map.adjust - (\cs -> cs { connectionRetries = retries + 1 }) - uri + ws { connections = Map.adjust + (\cs -> cs { connectionRetries = retries + 1 }) + uri' (connections ws) } - void $ tryConnect uri relayData + void $ tryConnect uri' relayData Nothing -> - logError $ "Cannot reconnect to " <> uri <> ": no connection state" + logError $ "Cannot reconnect to " <> uri' <> ": no connection state" -- Add periodic connection check startConnectionManager :: RelayPoolEff es => Eff es () @@ -422,11 +420,11 @@ shouldAttemptReconnect rd = _ -> False resetConnectionAttempts :: RelayPoolEff es => RelayURI -> Eff es () -resetConnectionAttempts uri = +resetConnectionAttempts uri' = modify @RelayPoolState $ \st -> st { activeConnections = Map.adjust (\rd -> rd { connectionAttempts = 0 }) - uri + uri' (activeConnections st) } @@ -450,14 +448,14 @@ relayPoolErrorToText = \case -- Add missing helper function findSubscriptionRelay :: RelayPoolState -> SubscriptionId -> Maybe RelayURI -findSubscriptionRelay st subId = - fst <$> find (elem subId . subscriptions . snd) (Map.toList $ activeConnections st) +findSubscriptionRelay st subId' = + fst <$> find (elem subId' . subscriptions . snd) (Map.toList $ activeConnections st) -- | Find the filters associated with a subscription ID findSubscriptionFilters :: RelayPoolState -> SubscriptionId -> Maybe [Filter] -findSubscriptionFilters st subId = do +findSubscriptionFilters st subId' = do -- Look up the subscription in the active subscriptions map - case Map.lookup subId (activeSubscriptions st) of + case Map.lookup subId' (activeSubscriptions st) of Just sub -> Just (subscriptionFilters sub) Nothing -> Nothing @@ -467,8 +465,8 @@ createSubscription :: RelayPoolEff es -> [Filter] -> RelayData -> Eff es (Maybe (SubscriptionId, TQueue Response)) -createSubscription relayURI' filters' relayData = do - status <- getConnectionStatus relayURI' +createSubscription uri' filters' relayData = do + status <- getConnectionStatus uri' case status of Just Connected -> do subId' <- generateID 8 @@ -478,12 +476,12 @@ createSubscription relayURI' filters' relayData = do { activeSubscriptions = Map.insert subId' (SubscriptionDetails { subscriptionFilters = filters' - , relayURI' = relayURI' + , relayURI' = uri' }) (activeSubscriptions s) } - updateSubscriptions relayURI' (subId' :) + updateSubscriptions uri' (subId' :) return $ Just (subId', responseQueue relayData) _ -> do - logWarning $ "Cannot start subscription: Relay " <> relayURI' <> " is not connected." + logWarning $ "Cannot start subscription: Relay " <> uri' <> " is not connected." return Nothing diff --git a/src/Nostr/Subscription.hs b/src/Nostr/Subscription.hs index 1767580..563fb1d 100644 --- a/src/Nostr/Subscription.hs +++ b/src/Nostr/Subscription.hs @@ -14,7 +14,7 @@ import Effectful import Effectful.Concurrent import Effectful.Concurrent.STM (TQueue, atomically, readTQueue, flushTQueue, writeTChan) import Effectful.Dispatch.Dynamic (interpret) -import Effectful.State.Static.Shared (State, get, modify, put) +import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH import Network.URI (parseURI, uriScheme, uriAuthority, uriRegName) @@ -272,7 +272,7 @@ handleEvent event' _ = do pure $ emptyUpdates { followsChanged = True } GiftWrap -> do - updates <- handleGiftWrapEvent event' + handleGiftWrapEvent event' pure $ emptyUpdates { chatsChanged = True } RelayListMetadata -> do diff --git a/src/Nostr/WebSocket.hs b/src/Nostr/WebSocket.hs index f39fe11..02e5746 100644 --- a/src/Nostr/WebSocket.hs +++ b/src/Nostr/WebSocket.hs @@ -14,7 +14,7 @@ import Data.Text qualified as T import Effectful import Effectful.Concurrent (Concurrent, forkIO, threadDelay) import Effectful.Concurrent.Async (async, race, waitAnyCancel) -import Effectful.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Effectful.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Effectful.Concurrent.STM (TChan, TQueue, atomically, readTChan, writeTQueue) import Effectful.Dispatch.Dynamic (EffectHandler, interpret) import Effectful.State.Static.Shared (State, evalState, get, modify) @@ -201,6 +201,14 @@ attemptConnection relay requestChan responseQueue = do Left _ -> return $ Right () Right err -> return $ Left err + (Nothing, _) -> do + logError $ "Invalid hostname in relay URI: " <> uri relay + return $ Left (ConnectionFailed "Invalid hostname in relay URI") + + (_, Nothing) -> do + logError $ "Invalid scheme in relay URI: " <> uri relay + return $ Left (ConnectionFailed "Invalid scheme in relay URI") + -- | Receive messages from the relay. receiveWs :: (WebSocketEff es, State WebSocketState :> es) diff --git a/src/Presentation/RelayMgmt.hs b/src/Presentation/RelayMgmt.hs index 26c79bd..ff03980 100644 --- a/src/Presentation/RelayMgmt.hs +++ b/src/Presentation/RelayMgmt.hs @@ -26,7 +26,7 @@ import Nostr.RelayPool import Nostr.Types hiding (displayName, picture) import Nostr.Util import Nostr.WebSocket hiding (notifyRelayStatus) -import Types (AppState(..), RelayData(..), Follow(..), FollowModel(..), OutboxModelState(..), RelayPoolState(..), UIReferences(..)) +import Types (AppState(..), RelayData(..), OutboxModelState(..), RelayPoolState(..), UIReferences(..)) data RelayType = DMRelays | InboxRelays | OutboxRelays @@ -306,7 +306,6 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action let rs = case Map.lookup pk (dmRelays outboxState) of Nothing -> [] Just (rs', _) -> rs' - runE $ logDebug $ "UI requesting DM relays: " <> pack (show rs) runE $ modify @AppState $ \s -> s { uiRefs = (uiRefs s) { preferredDMRelaysObjRef = Just obj } } @@ -322,6 +321,9 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action let rs = case Map.lookup pk (inboxes outboxState) of Nothing -> [] Just (rs', _) -> rs' + runE $ modify @AppState $ \s -> s { + uiRefs = (uiRefs s) { inboxRelaysObjRef = Just obj } + } mapM (getPoolObject inboxRelayPool) rs, defPropertySigRO' "outboxRelays" changeKey $ \obj -> do @@ -334,6 +336,9 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action let rs = case Map.lookup pk (outboxes outboxState) of Nothing -> [] Just (rs', _) -> rs' + runE $ modify @AppState $ \s -> s { + uiRefs = (uiRefs s) { outboxRelaysObjRef = Just obj } + } mapM (getPoolObject outboxRelayPool) rs, defMethod' "addPreferredDMRelay" $ \_ input -> runE $ do diff --git a/src/Types.hs b/src/Types.hs index 183e973..03f68bb 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -8,7 +8,7 @@ import Effectful.Concurrent.STM (TChan, TQueue) import Graphics.QML (ObjRef) import Nostr.Keys (KeyPair, PubKeyXO) -import Nostr.Types (Event, EventId, Filter, Profile, Relay, RelayInfo, RelayURI, Request, Response, SubscriptionId) +import Nostr.Types (Event, EventId, Filter, Profile, RelayInfo, RelayURI, Request, Response, SubscriptionId) -- | State for RelayPool handling. data RelayPoolState = RelayPoolState @@ -256,4 +256,5 @@ createRelayData info reqChan respQueue = RelayData , lastActivity = 0 , connectionAttempts = 0 , connectionState = RelayDisconnected + , notices = [] }