From 4068e3462e4115efd3b9b62bdbcedc63e524e954 Mon Sep 17 00:00:00 2001 From: prolic Date: Tue, 21 Jan 2025 03:29:19 -0300 Subject: [PATCH] Inbox Model - Updated lmdb - Remove relay pool's responsibility to manage relays lists - Split initialization logic into separate functions - Add proper subscription cleanup - Remove redundant event collection code - Add batched metadata updates with delay - Subscribe to own profile metadata on inbox relays - Improve error messages for subscription handling - Use ownInboxRelays as fallback when contact has no general relays - Separate relay tag types (RTag for relay list metadata, RelayTag for DM relays) - Move subscriptions from RelayData to RelayPool for centralized management - Remove NewSubscriptionId effect and generate IDs in Subscribe handler - Simplify subscription lifecycle with pending/active states - Send SubscriptionClosed events when stopping subscriptions --- futr.cabal | 2 +- .../content/Dialogs/RelayMgmtDialog.ui.qml | 40 +- src/Futr.hs | 162 +++--- src/KeyMgmt.hs | 40 +- src/Main.hs | 10 +- src/Nostr/Event.hs | 7 +- src/Nostr/InboxModel.hs | 491 +++++++++++++++++ src/Nostr/Publisher.hs | 106 ++-- src/Nostr/RelayConnection.hs | 156 +++--- src/Nostr/RelayPool.hs | 137 ----- src/Nostr/Subscription.hs | 513 +++++++----------- src/Nostr/Types.hs | 106 +++- src/Presentation/KeyMgmtUI.hs | 78 +-- src/Presentation/RelayMgmtUI.hs | 94 ++-- src/QtQuick.hs | 7 +- src/RelayMgmt.hs | 141 ++--- src/Store/Lmdb.hs | 373 +++++++++---- src/Types.hs | 27 +- src/UI.hs | 54 +- 19 files changed, 1422 insertions(+), 1122 deletions(-) create mode 100644 src/Nostr/InboxModel.hs delete mode 100644 src/Nostr/RelayPool.hs diff --git a/futr.cabal b/futr.cabal index 036a3ed..3186127 100755 --- a/futr.cabal +++ b/futr.cabal @@ -38,11 +38,11 @@ executable futr Nostr.Encryption Nostr.Encryption.Internal Nostr.Event + Nostr.InboxModel Nostr.Keys Nostr.Profile Nostr.Publisher Nostr.RelayConnection - Nostr.RelayPool Nostr.Subscription Nostr.Types Nostr.Util diff --git a/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml b/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml index 4692f63..6996ac8 100644 --- a/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml +++ b/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml @@ -85,18 +85,6 @@ Dialog { Layout.fillWidth: true } - Button { - text: modelData.connectionState === "Disconnected" ? qsTr("Connect") : qsTr("Disconnect") - Layout.preferredWidth: 100 - onClicked: { - if (modelData.connectionState === "Disconnected") { - ctxRelayMgmt.connectRelay(modelData.url) - } else { - ctxRelayMgmt.disconnectRelay(modelData.url) - } - } - } - Button { onClicked: { removeRelayDialog.relayToRemove = modelData.url @@ -196,9 +184,7 @@ Dialog { enabled: newDMRelaysInput.isValid onClicked: { if (newDMRelaysInput.text.trim() !== "") { - if (ctxRelayMgmt.addDMRelay(newDMRelaysInput.text.trim())) { - ctxRelayMgmt.connectRelay(newDMRelaysInput.text.trim()) - } + ctxRelayMgmt.addDMRelay(newDMRelaysInput.text.trim()) newDMRelaysInput.text = "" newDMRelaysInput.visible = false savePreferredButton.visible = false @@ -274,18 +260,6 @@ Dialog { enabled: false } - Button { - text: modelData.connectionState === "Disconnected" ? qsTr("Connect") : qsTr("Disconnect") - Layout.preferredWidth: 100 - onClicked: { - if (modelData.connectionState === "Disconnected") { - ctxRelayMgmt.connectRelay(modelData.url) - } else { - ctxRelayMgmt.disconnectRelay(modelData.url) - } - } - } - Button { onClicked: { removeRelayDialog.relayToRemove = modelData.url @@ -392,13 +366,11 @@ Dialog { enabled: newRelayInput.isValid onClicked: { if (newRelayInput.text.trim() !== "") { - if (ctxRelayMgmt.addGeneralRelay( + ctxRelayMgmt.addGeneralRelay( newRelayInput.text.trim(), newInboxRelayCheckboxCheckbox.checked, newOutboxRelayCheckbox.checked - )) { - ctxRelayMgmt.connectRelay(newRelayInput.text.trim()) - } + ); newRelayInput.text = "" newRelayInput.visible = false } @@ -456,12 +428,6 @@ Dialog { color: Material.primaryTextColor Layout.fillWidth: true } - - Button { - text: qsTr("Disconnect") - Layout.preferredWidth: 100 - onClicked: ctxRelayMgmt.disconnectRelay(modelData.url) - } } } } diff --git a/src/Futr.hs b/src/Futr.hs index ed1a5db..0c479a6 100644 --- a/src/Futr.hs +++ b/src/Futr.hs @@ -17,7 +17,7 @@ import Data.Typeable (Typeable) import Effectful import Effectful.Concurrent import Effectful.Concurrent.Async (async) -import Effectful.Concurrent.STM (atomically, readTQueue) +import Effectful.Concurrent.STM (atomically, newTQueueIO, readTQueue) import Effectful.Dispatch.Dynamic (interpret) import Effectful.Exception (SomeException, try) import Effectful.FileSystem @@ -42,18 +42,18 @@ import Nostr.Bech32 import Nostr.Event ( createComment, createEventDeletion, createFollowList , createQuoteRepost, createRepost, createRumor, createShortTextNote ) +import Nostr.InboxModel (InboxModel, awaitAtLeastOneConnected, startInboxModel, stopInboxModel) import Nostr.Keys (PubKeyXO, derivePublicKeyXO, keyPairToPubKeyXO, secKeyToKeyPair) import Nostr.Publisher -import Nostr.RelayConnection (RelayConnection) -import Nostr.RelayPool +import Nostr.RelayConnection (RelayConnection, connect, disconnect) import Nostr.Subscription -import Nostr.Types (Event(..), EventId, Relay(..), RelayURI, Tag(..), getUri) +import Nostr.Types (Event(..), EventId, RelayURI, Tag(..), getUri, isInboxCapable) import Nostr.Util import Presentation.KeyMgmtUI (KeyMgmtUI) import Presentation.RelayMgmtUI (RelayMgmtUI) import RelayMgmt (RelayMgmt) import Store.Lmdb ( LmdbState(..), LmdbStore, initialLmdbState, initializeLmdbState - , getEvent, getFollows, putEvent ) + , getEvent, getFollows, putEvent, getGeneralRelays ) import Types -- | Signal key class for LoginStatusChanged. @@ -102,28 +102,29 @@ makeEffect ''Futr -- | Effectful type for Futr. -type FutrEff es = ( State AppState :> es - , State LmdbState :> es - , LmdbStore :> es - , KeyMgmt :> es - , KeyMgmtUI :> es - , RelayMgmtUI :> es - , Nostr :> es - , RelayConnection :> es - , RelayMgmt :> es - , RelayPool :> es - , Subscription :> es - , Publisher :> es - , State KeyMgmtState :> es - , State RelayPoolState :> es - , State QtQuickState :> es - , QtQuick :> es - , Logging :> es - , IOE :> es - , FileSystem :> es - , Concurrent :> es - , Util :> es - ) +type FutrEff es = + ( State AppState :> es + , State LmdbState :> es + , LmdbStore :> es + , KeyMgmt :> es + , KeyMgmtUI :> es + , RelayMgmtUI :> es + , Nostr :> es + , InboxModel :> es + , RelayConnection :> es + , RelayMgmt :> es + , Subscription :> es + , Publisher :> es + , State KeyMgmtState :> es + , State RelayPool :> es + , State QtQuickState :> es + , QtQuick :> es + , Logging :> es + , IOE :> es + , FileSystem :> es + , Concurrent :> es + , Util :> es + ) -- | Run the Futr effect. @@ -191,7 +192,7 @@ runFutr = interpret $ \_ -> \case let newFollow = Follow targetPK Nothing newFollows = newFollow : currentFollows sendFollowListEvent newFollows - notify $ emptyUpdates { followsChanged = True } + notify $ emptyUpdates { myFollowsChanged = True } Nothing -> return () UnfollowProfile npub' -> do @@ -202,7 +203,7 @@ runFutr = interpret $ \_ -> \case currentFollows <- getFollows userPK let newFollows = filter ((/= targetPK) . pubkey) currentFollows sendFollowListEvent newFollows - notify $ emptyUpdates { followsChanged = True } + notify $ emptyUpdates { myFollowsChanged = True } Nothing -> return () OpenChat pubKeyXO -> do @@ -269,14 +270,11 @@ runFutr = interpret $ \_ -> \case , currentScreen = KeyMgmt } - -- Close relay connections - conns <- gets @RelayPoolState activeConnections - mapM_ disconnect (Map.keys conns) - + stopInboxModel -- Wait a moment for disconnects to process threadDelay 100000 -- 100ms delay - modify @RelayPoolState $ const initialRelayPoolState + modify @RelayPool $ const initialRelayPool fireSignal obj logInfo "User logged out successfully" @@ -300,14 +298,13 @@ runFutr = interpret $ \_ -> \case case mEventAndRelays of Just EventWithRelays{event = origEvent, relays = relaySet} -> do let eventRelayUris = Set.fromList $ map getUri $ - catMaybes [Just r | RelayTag r <- tags origEvent] + catMaybes [Just r | RTag r <- tags origEvent] - authorRelays <- gets @RelayPoolState $ \st' -> - maybe [] (filter isInboxCapable . fst) $ - Map.lookup (pubKey origEvent) (generalRelays st') + authorRelays <- getGeneralRelays (pubKey origEvent) + let authorInboxUris = Set.fromList $ map getUri $ + filter isInboxCapable authorRelays - let authorInboxUris = Set.fromList $ map getUri authorRelays - targetUris = eventRelayUris `Set.union` authorInboxUris `Set.union` relaySet + let targetUris = eventRelayUris `Set.union` authorInboxUris `Set.union` relaySet putEvent $ EventWithRelays s targetUris forM_ (Set.toList targetUris) $ \relay -> @@ -354,14 +351,13 @@ runFutr = interpret $ \_ -> \case case mEventAndRelays of Just EventWithRelays{event = origEvent, relays = relaySet} -> do let eventRelayUris = Set.fromList $ map getUri $ - catMaybes [Just r | RelayTag r <- tags origEvent] + catMaybes [Just r | RTag r <- tags origEvent] - authorRelays <- gets @RelayPoolState $ \st' -> - maybe [] (filter isInboxCapable . fst) $ - Map.lookup (pubKey origEvent) (generalRelays st') + authorRelays <- getGeneralRelays (pubKey origEvent) + let authorInboxUris = Set.fromList $ map getUri $ + filter isInboxCapable authorRelays - let authorInboxUris = Set.fromList $ map getUri authorRelays - targetUris = eventRelayUris `Set.union` authorInboxUris `Set.union` relaySet + let targetUris = eventRelayUris `Set.union` authorInboxUris `Set.union` relaySet putEvent $ EventWithRelays s targetUris forM_ (Set.toList targetUris) $ \relay -> @@ -399,8 +395,6 @@ parseNprofileOrNpub input = -- | Login with an account. loginWithAccount :: FutrEff es => ObjRef () -> Account -> Eff es () loginWithAccount obj a = do - let (rs, t) = accountRelays a - modify @AppState $ \s -> s { keyPair = Just (secKeyToKeyPair $ accountSecKey a) } modify @KeyMgmtState $ \st -> st @@ -408,11 +402,8 @@ loginWithAccount obj a = do , npubView = pubKeyXOToBech32 $ derivePublicKeyXO $ accountSecKey a } - importGeneralRelays (accountPubKeyXO a) rs t - - forM_ rs $ \relay' -> void $ async $ connect $ getUri relay' - void $ async $ do + startInboxModel atLeastOneConnected <- awaitAtLeastOneConnected -- Update UI state after connections are established when atLeastOneConnected $ do @@ -446,38 +437,41 @@ sendFollowListEvent follows = do -- | Search for a profile in relays. searchInRelays :: FutrEff es => PubKeyXO -> Maybe RelayURI -> Eff es () -searchInRelays pubkey' _ = do - -- @todo use relay hint - st <- get @RelayPoolState - let relays = case Map.lookup pubkey' (generalRelays st) of - Just (rs, _) -> rs - Nothing -> [] - conns <- gets @RelayPoolState activeConnections - forM_ relays $ \relay -> do - when (isInboxCapable relay) $ do - let relayUri' = getUri relay +searchInRelays xo mr = do + manuallyConnected <- case mr of + Just relayUri -> do + conns <- gets @RelayPool activeConnections + if Map.member relayUri conns + then return False + else do + void $ connect relayUri + return True + Nothing -> return False + + relays <- getGeneralRelays xo + conns <- gets @RelayPool activeConnections + + let searchRelays = case mr of + Just uri -> uri : map getUri relays + Nothing -> map getUri relays + + forM_ searchRelays $ \relayUri' -> do when (Map.member relayUri' conns) $ do - subId' <- newSubscriptionId - mq <- subscribe relayUri' subId' $ metadataFilter [pubkey'] - case mq of - Nothing -> return () - Just q -> void $ async $ do - let loop = do + q <- newTQueueIO + subId' <- subscribe relayUri' (metadataFilter [xo]) q + void $ async $ do + let loop = do e <- atomically $ readTQueue q case e of - EventAppeared event' -> do - updates <- handleEvent relayUri' subId' (metadataFilter [pubkey']) event' - notify updates - loop - SubscriptionEose -> do - stopSubscription subId' - loop - SubscriptionClosed _ -> return () -- stop the loop - loop - - --- | Check if a relay is inbox capable. -isInboxCapable :: Relay -> Bool -isInboxCapable (InboxRelay _) = True -isInboxCapable (InboxOutboxRelay _) = True -isInboxCapable _ = False + (r, EventAppeared event') -> do + updates <- handleEvent r event' + notify updates + loop + (_, SubscriptionEose) -> do + stopSubscription subId' + when (manuallyConnected && Just relayUri' == mr) $ do + disconnect relayUri' + (_, SubscriptionClosed _) -> + when (manuallyConnected && Just relayUri' == mr) $ do + disconnect relayUri' + loop diff --git a/src/KeyMgmt.hs b/src/KeyMgmt.hs index 94bfe38..f79e9b9 100644 --- a/src/KeyMgmt.hs +++ b/src/KeyMgmt.hs @@ -52,8 +52,7 @@ data Account = Account { accountSecKey :: SecKey, accountPubKeyXO :: PubKeyXO, accountDisplayName :: Maybe Text, - accountPicture :: Maybe Text, - accountRelays :: ([Relay], Int) + accountPicture :: Maybe Text } deriving (Eq, Show) @@ -101,7 +100,6 @@ data KeyMgmt :: Effect where ImportSeedphrase :: ObjRef () -> Text -> Text -> KeyMgmt m Bool GenerateSeedphrase :: ObjRef () -> KeyMgmt m (Maybe KeyPair) RemoveAccount :: ObjRef () -> Text -> KeyMgmt m () - UpdateRelays :: AccountId -> ([Relay], Int) -> KeyMgmt m () UpdateProfile :: AccountId -> Profile -> KeyMgmt m () type instance DispatchOf KeyMgmt = Dynamic @@ -190,19 +188,6 @@ runKeyMgmt = interpret $ \_ -> \case then removeDirectoryRecursive dir else return () - UpdateRelays aid newRelays -> do - modify $ \st -> st - { accountMap = Map.adjust (\acc -> acc { accountRelays = newRelays }) aid (accountMap st) } - accounts <- gets accountMap - case Map.lookup aid accounts of - Just account -> do - let npubStr = unpack $ pubKeyXOToBech32 $ accountPubKeyXO account - dir <- getXdgDirectory XdgData $ "futrnostr/" ++ npubStr - BL.writeFile (dir "relays.json") (encode newRelays) - Nothing -> do - logError $ "Account not found: " <>accountId aid - return () - UpdateProfile aid profile -> do modify $ \st -> st { accountMap = Map.adjust (\acc -> acc @@ -269,25 +254,8 @@ loadAccount :: (FileSystem :> es, IOE :> es) => FilePath -> FilePath -> Eff es ( loadAccount storageDir npubDir = do let dirPath = storageDir npubDir nsecContent <- readFileMaybe (dirPath "nsec") - relayData <- readJSONFile (dirPath "relays.json") profile <- readJSONFile (dirPath "profile.json") - -- Get and persist 3 random relays if no relay data exists - finalRelays <- case relayData of - Just r -> return r - Nothing -> do - randomRelays <- liftIO $ do - let (allRelays, _) = defaultGeneralRelays - indices <- randomRIO (0, length allRelays - 1) >>= \i1 -> do - i2 <- randomRIO (0, length allRelays - 1) - i3 <- randomRIO (0, length allRelays - 1) - return [i1, i2, i3] - let selectedRelays = nub $ map (allRelays !!) indices - return (selectedRelays, 0) -- 0 timestamp - -- Write the random selection to relays.json - BL.writeFile (dirPath "relays.json") (encode randomRelays) - return randomRelays - return $ do nsecKey <- bech32ToSecKey . strip =<< nsecContent pubKeyXO <- bech32ToPubKeyXO (pack npubDir) @@ -296,7 +264,6 @@ loadAccount storageDir npubDir = do Account { accountSecKey = nsecKey, accountPubKeyXO = pubKeyXO, - accountRelays = finalRelays, accountDisplayName = profile >>= \(Profile _ d _ _ _ _) -> d, accountPicture = profile >>= \(Profile _ _ _ p _ _) -> p } @@ -328,14 +295,13 @@ selectRandomRelays count relays = do -- | Create an AccountId and Account from a KeyPair. accountFromKeyPair :: (IOE :> es) => KeyPair -> Eff es (AccountId, Account) accountFromKeyPair kp = do - let (allRelays, _) = defaultGeneralRelays - selectedRelays <- liftIO $ selectRandomRelays 3 allRelays + --let (allRelays, _) = defaultGeneralRelays + --selectedRelays <- liftIO $ selectRandomRelays 3 allRelays let newNpub = pubKeyXOToBech32 $ keyPairToPubKeyXO kp let account = Account { accountSecKey = keyPairToSecKey kp, accountPubKeyXO = keyPairToPubKeyXO kp, - accountRelays = (selectedRelays, 0), -- 0 for initial timestamp accountDisplayName = Nothing, accountPicture = Nothing } diff --git a/src/Main.hs b/src/Main.hs index 0f67c34..a8990f6 100755 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,9 +12,9 @@ import Futr qualified as Futr import KeyMgmt (KeyMgmtState(..), initialState, runKeyMgmt) import Logging (runLoggingStdout) import Nostr +import Nostr.InboxModel (runInboxModel) import Nostr.Publisher (runPublisher) import Nostr.RelayConnection (runRelayConnection) -import Nostr.RelayPool (runRelayPool) import Nostr.Subscription (runSubscription) import Nostr.Util (runUtil) import Presentation.KeyMgmtUI (runKeyMgmtUI) @@ -22,7 +22,7 @@ import Presentation.RelayMgmtUI (runRelayMgmtUI) import RelayMgmt (runRelayMgmt) import UI qualified as UI import Store.Lmdb (LmdbState, initialLmdbState, runLmdbStore) -import Types (AppState(..), RelayPoolState(..)) +import Types (AppState(..), RelayPool(..)) import Types qualified as Types -- | Main function for the app. @@ -56,7 +56,7 @@ main = do . runPublisher . runRelayMgmt . runSubscription - . runRelayPool + . runInboxModel -- presentation related . runKeyMgmtUI . runRelayMgmtUI @@ -79,7 +79,7 @@ main = do -- | Initialize the state for the app. withInitialState - :: Eff ( State RelayPoolState + :: Eff ( State RelayPool : State KeyMgmtState : State AppState : State LmdbState @@ -89,4 +89,4 @@ withInitialState = evalState initialLmdbState . evalState Types.initialState . evalState KeyMgmt.initialState - . evalState Types.initialRelayPoolState + . evalState Types.initialRelayPool diff --git a/src/Nostr/Event.hs b/src/Nostr/Event.hs index f5b3552..5310a7a 100755 --- a/src/Nostr/Event.hs +++ b/src/Nostr/Event.hs @@ -222,7 +222,7 @@ createRelayListMetadataEvent relays xo t = { pubKey' = xo , createdAt' = t , kind' = RelayListMetadata - , tags' = map (\r -> RelayTag r) relays + , tags' = map (\r -> RTag r) relays , content' = "" } @@ -233,7 +233,7 @@ createPreferredDMRelaysEvent urls xo t = { pubKey' = xo , createdAt' = t , kind' = PreferredDMRelays - , tags' = map (\url -> RelayTag $ InboxOutboxRelay url) urls + , tags' = map (\url -> RelayTag url) urls , content' = "" } @@ -244,8 +244,7 @@ createCanonicalAuthentication r challenge xo t = { pubKey' = xo , createdAt' = t , kind' = CanonicalAuthentication - -- force the relay to be a InboxOutboxRelay for the purpose of authentication - , tags' = [RelayTag $ InboxOutboxRelay r, ChallengeTag challenge] + , tags' = [RelayTag $ r, ChallengeTag challenge] , content' = "" } diff --git a/src/Nostr/InboxModel.hs b/src/Nostr/InboxModel.hs new file mode 100644 index 0000000..0e45723 --- /dev/null +++ b/src/Nostr/InboxModel.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Nostr.InboxModel where + +import Control.Monad (forever, forM, forM_, unless, void, when) +import Data.Either (partitionEithers) +import Data.List (partition) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.Set qualified as Set +import Data.Text (pack, unpack) +import Effectful +import Effectful.Concurrent +import Effectful.Concurrent.Async (async, cancel,forConcurrently) +import Effectful.Concurrent.STM +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get, gets, put, modify) +import Effectful.TH + +import Logging +import Nostr +import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) +import Nostr.RelayConnection (RelayConnection, connect, disconnect) +import Nostr.Subscription + ( Subscription + , giftWrapFilter + , handleEvent + , mentionsFilter + , profilesFilter + , stopAllSubscriptions + , stopSubscription + , subscribe + , userPostsFilter + ) +import Nostr.Types + ( RelayURI + , Relay(..) + , Event(..) + , Filter(..) + , Kind(..) + , SubscriptionId + , getUri + , isInboxCapable + , isOutboxCapable + , defaultGeneralRelays + ) +import Nostr.Util +import QtQuick (QtQuick, UIUpdates(..), notify) +import RelayMgmt +import Store.Lmdb (LmdbStore, getFollows, getGeneralRelays, getDMRelays, getLatestTimestamp) +import Types (AppState(..), ConnectionState(..), Follow(..), SubscriptionDetails(..), RelayPool(..), RelayData(..), SubscriptionEvent(..), initialRelayPool) + +-- | InboxModel effects +data InboxModel :: Effect where + StartInboxModel :: InboxModel m () + StopInboxModel :: InboxModel m () + AwaitAtLeastOneConnected :: InboxModel m Bool + +type instance DispatchOf InboxModel = Dynamic + +makeEffect ''InboxModel + +type InboxModelEff es = + ( State AppState :> es + , State RelayPool :> es + , LmdbStore :> es + , Subscription :> es + , RelayConnection :> es + , RelayMgmt :> es + , Logging :> es + , Concurrent :> es + , Util :> es + , Nostr :> es + , QtQuick :> es + ) + +-- | Run InboxModel +runInboxModel :: InboxModelEff es => Eff (InboxModel : es) a -> Eff es a +runInboxModel = interpret $ \_ -> \case + StartInboxModel -> do + kp <- getKeyPair + let xo = keyPairToPubKeyXO kp + queue <- newTQueueIO + updateQueue <- newTQueueIO + + -- Start the event processing loop + void $ async $ do + initializeSubscriptions xo + eventLoop xo + + -- Start and track the batched update loop + updateThread <- async $ forever $ do + void $ atomically $ readTQueue updateQueue + void $ atomically $ flushTQueue updateQueue + logInfo "Processing batched metadata updates." + updateSubscriptions xo + threadDelay 20000000 -- Wait 20 seconds + + modify @RelayPool (\s -> s { inboxQueue = queue + , updateQueue = updateQueue + , updateThread = Just updateThread + }) + + StopInboxModel -> do + st <- get @RelayPool + -- Cancel the update thread if it exists + forM_ (updateThread st) cancel + modify @RelayPool $ \s -> s { updateThread = Nothing } + -- Disconnect all relays + forM_ (Map.keys $ activeConnections st) $ \relayUri -> do + disconnect relayUri + put @RelayPool initialRelayPool + + AwaitAtLeastOneConnected -> awaitAtLeastOneConnected' + +-- | Wait until at least one relay is connected +awaitAtLeastOneConnected' :: InboxModelEff es => Eff es Bool +awaitAtLeastOneConnected' = do + let loop = do + st <- get @RelayPool + let states = map (connectionState . snd) $ Map.toList $ activeConnections st + if any (== Connected) states + then return True + else if null states + then do + threadDelay 50000 -- 50ms delay + loop + else if all (== Disconnected) states + then return False + else do + threadDelay 50000 -- 50ms delay + loop + loop + +-- | Initialize subscriptions +initializeSubscriptions :: InboxModelEff es => PubKeyXO -> Eff es () +initializeSubscriptions xo = do + follows <- getFollows xo + let followList = map pubkey follows + logDebug $ "Follow List: " <> pack (show followList) + + inboxRelays <- getGeneralRelays xo + + if null inboxRelays + then initializeWithDefaultRelays xo + else initializeWithExistingRelays xo followList inboxRelays + +-- | Initialize using default relays when no relay configuration exists +initializeWithDefaultRelays :: InboxModelEff es => PubKeyXO -> Eff es () +initializeWithDefaultRelays xo = do + let (defaultRelays, _) = defaultGeneralRelays + + connectionResults <- forConcurrently defaultRelays $ \relay -> do + connected <- connect (getUri relay) + return (relay, connected) + + void $ awaitAtLeastOneConnected' + + let connectedRelays = [relay | (relay, success) <- connectionResults, success] + + initQueue <- newTQueueIO + let filter' = profilesFilter [xo] Nothing + + subIds <- subscribeToFilter connectedRelays filter' initQueue + logDebug "Looking for relay data on default relays..." + receivedEvents <- collectEventsUntilEose initQueue + + forM_ receivedEvents $ \(r, e') -> do + case e' of + EventAppeared e'' -> do + updates <- handleEvent r e'' + notify updates + _ -> return () + + forM_ subIds stopSubscription + + follows <- getFollows xo + let followList = map pubkey follows + + unless (null followList) $ do + let filter'' = profilesFilter followList Nothing + + subIds' <- subscribeToFilter connectedRelays filter'' initQueue + logDebug "Looking for follower data on default relays..." + receivedEvents' <- collectEventsUntilEose initQueue + + forM_ receivedEvents' $ \(r, e') -> do + case e' of + EventAppeared e'' -> do + updates <- handleEvent r e'' + notify updates + _ -> return () + + forM_ subIds' stopSubscription + + let hasRelayMeta = hasRelayListMetadata $ map snd receivedEvents + hasPreferredDM = hasPreferredDMRelays $ map snd receivedEvents + + unless hasRelayMeta $ do + logInfo "RelayListMetadata event not found. Setting default general relays." + setDefaultGeneralRelays xo + + unless hasPreferredDM $ do + logInfo "PreferredDMRelays event not found. Setting default DM relays." + setDefaultDMRelays xo + + -- Continue with appropriate relays + inboxRelays <- getGeneralRelays xo + dmRelays <- getDMRelays xo + continueWithRelays followList inboxRelays dmRelays + +-- | Initialize with existing relay configuration +initializeWithExistingRelays :: InboxModelEff es => PubKeyXO -> [PubKeyXO] -> [Relay] -> Eff es () +initializeWithExistingRelays xo followList inboxRelays = do + dmRelays <- getDMRelays xo + continueWithRelays followList inboxRelays dmRelays + +-- | Subscribe to a filter on multiple relays +subscribeToFilter + :: InboxModelEff es + => [Relay] + -> Filter + -> TQueue (RelayURI, SubscriptionEvent) + -> Eff es [SubscriptionId] +subscribeToFilter relays f queue = do + forM relays $ \relay -> do + let relayUri = getUri relay + subscribe relayUri f queue + +-- | Collect events until EOSE is received +collectEventsUntilEose :: InboxModelEff es => TQueue (RelayURI, SubscriptionEvent) -> Eff es [(RelayURI, SubscriptionEvent)] +collectEventsUntilEose queue = do + let loop acc = do + event <- atomically $ readTQueue queue + case snd event of + SubscriptionEose -> return acc + SubscriptionClosed _ -> return acc + _ -> loop (event : acc) + loop [] + +-- | Check if RelayListMetadata event is present +hasRelayListMetadata :: [SubscriptionEvent] -> Bool +hasRelayListMetadata events = any isRelayListMetadata events + where + isRelayListMetadata (EventAppeared event') = kind event' == RelayListMetadata + isRelayListMetadata _ = False + +-- | Check if PreferredDMRelays event is present +hasPreferredDMRelays :: [SubscriptionEvent] -> Bool +hasPreferredDMRelays events = any isPreferredDMRelays events + where + isPreferredDMRelays (EventAppeared event') = kind event' == PreferredDMRelays + isPreferredDMRelays _ = False + +-- | Continue with discovered relays +continueWithRelays :: InboxModelEff es => [PubKeyXO] -> [Relay] -> [RelayURI] -> Eff es () +continueWithRelays followList inboxRelays dmRelays = do + kp <- getKeyPair + let xo = keyPairToPubKeyXO kp + let ownInboxRelayURIs = [ getUri relay | relay <- inboxRelays, isInboxCapable relay ] + logDebug $ "Initializing subscriptions for Discovered Inbox Relays: " <> pack (show ownInboxRelayURIs) + logDebug $ "Initializing subscriptions for Discovered DM Relays: " <> pack (show dmRelays) + + -- Connect to DM relays concurrently + void $ forConcurrently dmRelays $ \relay -> do + connected <- connect relay + if connected + then do + subscribeToGiftwraps relay xo + logInfo $ "Subscribed to Giftwraps on relay: " <> relay + else + logError $ "Failed to connect to DM Relay: " <> relay + + -- Connect to inbox relays concurrently + void $ forConcurrently inboxRelays $ \relay -> do + let relayUri = getUri relay + connected <- connect relayUri + if connected + then do + when (isInboxCapable relay) $ do + subscribeToMentionsAndProfiles relayUri xo + logInfo $ "Subscribed to Mentions on relay: " <> relayUri + else + logError $ "Failed to connect to Inbox Relay: " <> relayUri + + logDebug "Building Relay-PubKey Map..." + logDebug $ "Follow List: " <> pack (show followList) + logDebug $ "Own Inbox Relays: " <> pack (show ownInboxRelayURIs) + followRelayMap <- buildRelayPubkeyMap followList ownInboxRelayURIs + logDebug $ "Building Relay-PubKey Map: " <> pack (show followRelayMap) + + -- Connect to follow relays concurrently + void $ forConcurrently (Map.toList followRelayMap) $ \(relayUri, pubkeys) -> do + connected <- connect relayUri + if connected + then do + subscribeToRelay relayUri pubkeys + logInfo $ "Subscribed to Relay: " <> relayUri <> " for PubKeys: " <> pack (show pubkeys) + else + logError $ "Failed to connect to Follow Relay: " <> relayUri + +-- | Subscribe to Giftwrap events on a relay +subscribeToGiftwraps :: InboxModelEff es => RelayURI -> PubKeyXO -> Eff es () +subscribeToGiftwraps relayUri xo = do + lastTimestamp <- getSubscriptionTimestamp [xo] [GiftWrap] + queue <- gets @RelayPool inboxQueue + void $ subscribe relayUri (giftWrapFilter xo lastTimestamp) queue + +-- | Subscribe to mentions on a relay +subscribeToMentionsAndProfiles :: InboxModelEff es => RelayURI -> PubKeyXO -> Eff es () +subscribeToMentionsAndProfiles relayUri xo = do + lastTimestamp <- getSubscriptionTimestamp [xo] [ShortTextNote, Repost, Comment, EventDeletion] + queue <- gets @RelayPool inboxQueue + void $ subscribe relayUri (mentionsFilter xo lastTimestamp) queue + void $ subscribe relayUri (profilesFilter [xo] Nothing) queue + + +-- | Subscribe to profiles and posts for a relay +subscribeToRelay :: InboxModelEff es => RelayURI -> [PubKeyXO] -> Eff es () +subscribeToRelay relayUri pks = do + -- Subscribe to profiles + queue <- gets @RelayPool inboxQueue + void $ subscribe relayUri (profilesFilter pks Nothing) queue + + -- Subscribe to posts + postsLastTimestamp <- getSubscriptionTimestamp pks [ShortTextNote, Repost, EventDeletion] + void $ subscribe relayUri (userPostsFilter pks postsLastTimestamp) queue + + +getSubscriptionTimestamp :: InboxModelEff es => [PubKeyXO] -> [Kind] -> Eff es (Maybe Int) +getSubscriptionTimestamp pks ks = do + timestamps <- forM pks $ \pk -> getLatestTimestamp pk ks + if null timestamps + then return Nothing + else case catMaybes timestamps of + [] -> return Nothing + ts -> return $ Just $ minimum ts + +-- | Build a map from relay URI to pubkeys, prioritizing existing inbox relays +buildRelayPubkeyMap :: InboxModelEff es => [PubKeyXO] -> [RelayURI] -> Eff es (Map.Map RelayURI [PubKeyXO]) +buildRelayPubkeyMap pks ownInboxRelays = do + relayPubkeyPairs <- forM pks $ \pk -> do + relays <- getGeneralRelays pk + let outboxRelayURIs = [ getUri relay | relay <- relays, isOutboxCapable relay ] + let selectedRelays = if null outboxRelayURIs + then ownInboxRelays + else let (prioritized, other) = partition (`elem` ownInboxRelays) outboxRelayURIs + in take maxRelaysPerContact $ prioritized ++ other + return (pk, selectedRelays) + + return $ Map.filter (not . null) $ foldr (\(pk, relays) acc -> + foldr (\relay acc' -> Map.insertWith (++) relay [pk] acc') acc relays + ) Map.empty relayPubkeyPairs + +-- | Maximum number of outbox relays to consider per contact +maxRelaysPerContact :: Int +maxRelaysPerContact = 3 + +-- | Event loop to handle incoming events and updates +eventLoop :: InboxModelEff es => PubKeyXO -> Eff es () +eventLoop xo = do + shouldStopVar <- newTVarIO False + updateScheduledVar <- newTVarIO False + + let loop = do + events <- collectEvents + + forM_ events $ \(relayUri, event) -> do + case event of + EventAppeared event' -> do + updates <- handleEvent relayUri event' + when (followsChanged updates || dmRelaysChanged updates || generalRelaysChanged updates) $ do + updateSubscriptions xo + notify updates + SubscriptionEose -> return () + SubscriptionClosed _ -> atomically $ writeTVar shouldStopVar True + + shouldStop <- atomically $ readTVar shouldStopVar + unless shouldStop loop + loop + +-- | Collect events from all active subscriptions +collectEvents :: InboxModelEff es => Eff es [(RelayURI, SubscriptionEvent)] +collectEvents = do + queue <- gets @RelayPool inboxQueue + atomically $ do + event <- readTQueue queue + remainingEvents <- flushTQueue queue + return (event : remainingEvents) + +-- | Update subscriptions when follows or preferred DM relays change +updateSubscriptions :: InboxModelEff es => PubKeyXO -> Eff es () +updateSubscriptions xo = do + updateGeneralSubscriptions xo + updateDMSubscriptions xo + +-- | Update general subscriptions based on current follow list +updateGeneralSubscriptions :: InboxModelEff es => PubKeyXO -> Eff es () +updateGeneralSubscriptions xo = do + follows <- getFollows xo + let followList = map pubkey follows + + inboxRelays <- getGeneralRelays xo + let ownInboxRelayURIs = [ getUri relay | relay <- inboxRelays, isInboxCapable relay ] + + void $ forConcurrently inboxRelays $ \relay -> do + when (isInboxCapable relay) $ do + let relayUri = getUri relay + connected <- connect relayUri + when connected $ subscribeToMentionsAndProfiles relayUri xo + + newRelayPubkeyMap <- buildRelayPubkeyMap followList ownInboxRelayURIs + + pool <- get @RelayPool + let currentRelays = Map.keysSet (activeConnections pool) + let newRelays = Map.keysSet newRelayPubkeyMap + + let relaysToAdd = Set.difference newRelays currentRelays + let relaysToRemove = Set.difference currentRelays newRelays + let relaysToUpdate = Set.intersection currentRelays newRelays + + void $ forConcurrently (Set.toList relaysToRemove) $ \relayUri -> do + disconnect relayUri + + void $ forConcurrently (Set.toList relaysToAdd) $ \relayUri -> do + let pubkeys = Map.findWithDefault [] relayUri newRelayPubkeyMap + connected <- connect relayUri + when connected $ do + subscribeToRelay relayUri pubkeys + + void $ forConcurrently (Set.toList relaysToUpdate) $ \relayUri -> do + let newPubkeys = Set.fromList $ Map.findWithDefault [] relayUri newRelayPubkeyMap + let currentPubkeys = Set.fromList $ getSubscribedPubkeys pool relayUri + when (newPubkeys /= currentPubkeys) $ do + stopAllSubscriptions relayUri + subscribeToRelay relayUri (Set.toList newPubkeys) + +-- | Update DM subscriptions +updateDMSubscriptions :: InboxModelEff es => PubKeyXO -> Eff es () +updateDMSubscriptions xo = do + kp <- getKeyPair + let ownPubkey = keyPairToPubKeyXO kp + + when (xo == ownPubkey) $ do + dmRelayURIs <- getDMRelays xo + let dmRelaySet = Set.fromList dmRelayURIs + pool <- get @RelayPool + + let giftwrapSubs = + [ (relayUri, subId) + | (subId, sd) <- Map.toList (subscriptions pool) + , GiftWrap `elem` fromMaybe [] (kinds $ subscriptionFilter sd) + , relayUri <- Map.keys (activeConnections pool) + , not (relayUri `Set.member` dmRelaySet) + ] + + -- Stop giftwrap subscriptions for relays not in dmRelaySet + void $ forConcurrently giftwrapSubs $ \(relayUri, subId) -> do + stopSubscription subId + let hasOtherSubs = any (\sd -> relayUri == relayUri) + (Map.elems $ subscriptions pool) + when (not hasOtherSubs) $ do + disconnect relayUri + + let currentRelaySet = Map.keysSet (activeConnections pool) + let relaysToAdd = Set.difference dmRelaySet currentRelaySet + + void $ forConcurrently (Set.toList relaysToAdd) $ \relayUri -> do + connected <- connect relayUri + when connected $ do + subscribeToGiftwraps relayUri xo + +-- | Get RelayData for a relay +getRelayData :: InboxModelEff es => RelayURI -> Eff es RelayData +getRelayData relayUri = do + st <- get @RelayPool + return $ fromMaybe (error $ "No RelayData for " <> unpack relayUri) $ Map.lookup relayUri (activeConnections st) + +-- | Get pubkeys from subscriptions in RelayData +getSubscribedPubkeys :: RelayPool -> RelayURI -> [PubKeyXO] +getSubscribedPubkeys pool relayUri = + [ pk + | sd <- Map.elems (subscriptions pool) + , pk <- fromMaybe [] (authors $ subscriptionFilter sd) + ] diff --git a/src/Nostr/Publisher.hs b/src/Nostr/Publisher.hs index 3504b6c..1d57cee 100644 --- a/src/Nostr/Publisher.hs +++ b/src/Nostr/Publisher.hs @@ -1,8 +1,9 @@ module Nostr.Publisher where -import Control.Monad (forM_, when) +import Control.Monad (forM, forM_, when) import Data.List (nub, partition) import Data.Map.Strict qualified as Map +import Data.Set qualified as Set import Data.Text (Text, pack) import Effectful import Effectful.Concurrent (Concurrent) @@ -18,11 +19,11 @@ import Logging import Nostr.Bech32 (pubKeyXOToBech32) import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) import Nostr.RelayConnection -import Nostr.Types (Event(..), EventId, Relay(..), RelayURI, Request(..), getUri) +import Nostr.Types (Event(..), EventId, Relay(..), RelayURI, Request(..), getUri, isInboxCapable, isOutboxCapable) import Nostr.Util -import Store.Lmdb (LmdbStore, getFollows) -import Types ( AppState(..), ConnectionState(..), Follow(..) - , PublishStatus(..), RelayData(..), RelayPoolState(..) ) +import Store.Lmdb (LmdbStore, getFollows, getDMRelays, getGeneralRelays, putEvent) +import Types ( AppState(..), ConnectionState(..), EventWithRelays(..), Follow(..) + , PublishStatus(..), RelayData(..), RelayPool(..) ) -- | Result of a publish operation @@ -48,7 +49,7 @@ makeEffect ''Publisher -- | Publisher effect handlers type PublisherEff es = ( State AppState :> es - , State RelayPoolState :> es + , State RelayPool :> es , LmdbStore :> es , RelayConnection :> es , QtQuick :> es @@ -64,27 +65,31 @@ runPublisher => Eff (Publisher : es) a -> Eff es a runPublisher = interpret $ \_ -> \case - Broadcast event -> do - allDMRelays <- gets @RelayPoolState (concatMap (fst . snd) . Map.toList . dmRelays) - - myGeneralRelays <- gets @RelayPoolState (Map.findWithDefault ([], 0) (pubKey event) . generalRelays) - let (myOutboxCapable, _) = partition isOutboxCapable (fst myGeneralRelays) - + Broadcast event' -> do + putEvent $ EventWithRelays event' Set.empty + kp <- getKeyPair - let pk = keyPairToPubKeyXO kp - follows <- getFollows pk + let xo = keyPairToPubKeyXO kp + + dmRelays <- getDMRelays xo + myGeneralRelays <- getGeneralRelays xo + let outboxCapable = filter isOutboxCapable myGeneralRelays + + follows <- getFollows xo let followPks = map pubkey follows - otherGeneralRelays <- gets @RelayPoolState (concatMap (fst . snd) . - filter (\(k,_) -> k `elem` followPks && k /= pubKey event) . Map.toList . generalRelays) - + + followerRelays <- forM followPks $ \pk -> do + relays <- getGeneralRelays pk + return $ filter isInboxCapable relays + let allTargetRelays = nub $ - map getUri allDMRelays ++ - map getUri myOutboxCapable ++ - map getUri otherGeneralRelays + dmRelays ++ + map getUri outboxCapable ++ + concatMap (map getUri) followerRelays modify $ \st' -> st' { publishStatus = Map.insert - (eventId event) + (eventId event') (Map.fromList [(relay, Publishing) | relay <- allTargetRelays]) (publishStatus st') } @@ -92,31 +97,34 @@ runPublisher = interpret $ \_ -> \case existingConnections <- getConnectedRelays let (existingRelays, newRelays) = partition (`elem` existingConnections) allTargetRelays - forM_ existingRelays $ \r -> writeToChannel event r + forM_ existingRelays $ \r -> writeToChannel event' r forM_ newRelays $ \r -> async $ do - connected <- connectRelay r + connected <- connect r when connected $ do - writeToChannel event r - disconnectRelay r + writeToChannel event' r + disconnect r + + PublishToOutbox event' -> do + putEvent $ EventWithRelays event' Set.empty - PublishToOutbox event -> do kp <- getKeyPair let pk = keyPairToPubKeyXO kp - generalRelayList <- gets (Map.findWithDefault ([], 0) pk . generalRelays) - let (outboxRelays, _) = generalRelayList - outboxCapableURIs = map getUri $ filter isOutboxCapable outboxRelays + + generalRelayList <- getGeneralRelays pk + let outboxCapableURIs = map getUri $ filter isOutboxCapable generalRelayList modify $ \st -> st { publishStatus = Map.insert - (eventId event) + (eventId event') (Map.fromList [(relay, Publishing) | relay <- outboxCapableURIs]) (publishStatus st) } - forM_ outboxCapableURIs $ \r -> writeToChannel event r + forM_ outboxCapableURIs $ \r -> writeToChannel event' r PublishToRelay event' relayUri' -> do + putEvent $ EventWithRelays event' $ Set.empty modify $ \st -> st { publishStatus = Map.adjust (\existingMap -> Map.insert relayUri' Publishing existingMap) @@ -126,40 +134,29 @@ runPublisher = interpret $ \_ -> \case writeToChannel event' relayUri' PublishGiftWrap event' senderPk -> do - logDebug $ "Publishing gift wrap" - -- Log subscription details - logDebug $ "Publishing gift wrap event: " <> pack (show $ eventId event') - logDebug $ "Sender pubkey: " <> pubKeyXOToBech32 senderPk - logDebug $ "Recipient pubkey: " <> pubKeyXOToBech32 (pubKey event') - -- Get sender and recipient relay lists - dmRelayList <- gets @RelayPoolState (Map.findWithDefault ([], 0) senderPk . dmRelays) - recipientDMRelays <- gets @RelayPoolState (Map.findWithDefault ([], 0) (pubKey event') . dmRelays) + putEvent $ EventWithRelays event' Set.empty + dmRelayList <- getDMRelays senderPk + recipientDMRelays <- getDMRelays (pubKey event') if null dmRelayList || null recipientDMRelays then pure () else do - let allRelayURIs = nub $ - map getUri (fst dmRelayList) ++ - map getUri (fst recipientDMRelays) + let allRelayURIs = nub $ dmRelayList ++ recipientDMRelays - -- Split relays into existing connections and new ones existingConnections <- getConnectedRelays let (existingRelays, newRelays) = partition (`elem` existingConnections) allRelayURIs - -- Handle existing connections forM_ existingRelays $ \r -> writeToChannel event' r - - -- Handle new connections forM_ newRelays $ \r -> async $ do - connected <- connectRelay r + connected <- connect r when connected $ do writeToChannel event' r - disconnectRelay r + disconnect r GetPublishResult eventId' -> do - st <- get @RelayPoolState + st <- get @RelayPool let states = Map.findWithDefault Map.empty eventId' (publishStatus st) if null states then return $ PublishFailure "No relays found to publish to" @@ -171,7 +168,7 @@ runPublisher = interpret $ \_ -> \case -- | Write an event to a channel writeToChannel :: PublisherEff es => Event -> RelayURI -> Eff es () writeToChannel e r = do - st <- get @RelayPoolState + st <- get @RelayPool case Map.lookup r (activeConnections st) of Just rd -> do atomically $ writeTChan (requestChannel rd) (SendEvent e) @@ -183,12 +180,5 @@ writeToChannel e r = do -- | Get the connected relays getConnectedRelays :: PublisherEff es => Eff es [RelayURI] getConnectedRelays = do - st <- get @RelayPoolState + st <- get @RelayPool return $ Map.keys $ Map.filter ((== Connected) . connectionState) (activeConnections st) - - --- | Check if a relay is outbox capable -isOutboxCapable :: Relay -> Bool -isOutboxCapable (OutboxRelay _) = True -isOutboxCapable (InboxOutboxRelay _) = True -isOutboxCapable _ = False diff --git a/src/Nostr/RelayConnection.hs b/src/Nostr/RelayConnection.hs index f6e432d..ab08d86 100644 --- a/src/Nostr/RelayConnection.hs +++ b/src/Nostr/RelayConnection.hs @@ -28,12 +28,11 @@ import Logging import Nostr import Nostr.Event (createCanonicalAuthentication) import Nostr.Keys (keyPairToPubKeyXO) -import Nostr.Types ( Event(..), RelayURI - , Request(..), Response(..), SubscriptionId ) +import Nostr.Types (Event(..), RelayURI, Response(..), SubscriptionId) import Nostr.Types qualified as NT import Nostr.Util import Types ( AppState(..), ConnectionError(..), ConnectionState(..) - , RelayPoolState(..), RelayData(..) + , RelayPool(..), RelayData(..) , SubscriptionDetails(..), SubscriptionEvent(..)) @@ -44,8 +43,8 @@ data DisconnectReason = UserInitiated | ConnectionFailure -- | Effect for handling RelayPool operations. data RelayConnection :: Effect where - ConnectRelay :: RelayURI -> RelayConnection m Bool - DisconnectRelay :: RelayURI -> RelayConnection m () + Connect :: RelayURI -> RelayConnection m Bool + Disconnect :: RelayURI -> RelayConnection m () type instance DispatchOf RelayConnection = Dynamic @@ -57,7 +56,7 @@ makeEffect ''RelayConnection -- | RelayConnectionEff type RelayConnectionEff es = ( State AppState :> es - , State RelayPoolState :> es + , State RelayPool :> es , Nostr :> es , QtQuick :> es , Concurrent :> es @@ -73,9 +72,9 @@ runRelayConnection => Eff (RelayConnection : es) a -> Eff es a runRelayConnection = interpret $ \_ -> \case - ConnectRelay r -> do + Connect r -> do let r' = normalizeRelayURI r - conns <- gets @RelayPoolState activeConnections + conns <- gets @RelayPool activeConnections if Map.member r' conns then do let connState = connectionState <$> Map.lookup r' conns @@ -98,7 +97,6 @@ runRelayConnection = interpret $ \_ -> \case let rd = RelayData { connectionState = Connecting , requestChannel = chan - , activeSubscriptions = Map.empty , lastError = Nothing , connectionAttempts = 0 , notices = [] @@ -106,30 +104,30 @@ runRelayConnection = interpret $ \_ -> \case , pendingEvents = [] , pendingAuthId = Nothing } - modify @RelayPoolState $ \st -> + modify @RelayPool $ \st -> st { activeConnections = Map.insert r' rd (activeConnections st) } connectWithRetry r' 5 chan - DisconnectRelay r -> do + Disconnect r -> do let r' = normalizeRelayURI r - st <- get @RelayPoolState + st <- get @RelayPool case Map.lookup r' (activeConnections st) of Just rd -> do void $ atomically $ writeTChan (requestChannel rd) NT.Disconnect - modify @RelayPoolState $ \st' -> + modify @RelayPool $ \st' -> st' { activeConnections = Map.delete r' (activeConnections st') } Nothing -> return () -- | Connect with retry. -connectWithRetry :: RelayConnectionEff es => RelayURI -> Int -> TChan Request -> Eff es Bool +connectWithRetry :: RelayConnectionEff es => RelayURI -> Int -> TChan NT.Request -> Eff es Bool connectWithRetry r maxRetries requestChan = do - st <- get @RelayPoolState + st <- get @RelayPool let attempts = maybe 0 connectionAttempts $ Map.lookup r (activeConnections st) if attempts >= maxRetries then do - modify @RelayPoolState $ \st' -> + modify @RelayPool $ \st' -> st' { activeConnections = Map.adjust (\d -> d { connectionState = Disconnected , lastError = Just MaxRetriesReached @@ -141,9 +139,18 @@ connectWithRetry r maxRetries requestChan = do else do connectionMVar <- newEmptyTMVarIO - let connectAction = if "wss://" `T.isPrefixOf` r - then Wuss.runSecureClient (T.unpack $ T.drop 6 r) 443 "/" - else WS.runClient (T.unpack $ T.drop 5 r) 80 "/" + let connectAction = case parseURI (T.unpack r) of + Just uri -> case uriAuthority uri of + Just auth -> + let host = uriRegName auth + port = case uriPort auth of + "" -> if "wss://" `T.isPrefixOf` r then 443 else 80 + p -> read (drop 1 p) -- drop the leading ':' + in if "wss://" `T.isPrefixOf` r + then Wuss.runSecureClient host port "/" + else WS.runClient host (fromIntegral port) "/" + Nothing -> error $ "Invalid relay URI (no authority): " ++ T.unpack r + Nothing -> error $ "Invalid relay URI: " ++ T.unpack r void $ forkIO $ withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> do let runClient = nostrClient connectionMVar r requestChan runE @@ -153,9 +160,9 @@ connectWithRetry r maxRetries requestChan = do Left e -> runE $ do atomically $ putTMVar connectionMVar False logError $ "Connection error: " <> T.pack (show e) - st' <- get @RelayPoolState + st' <- get @RelayPool when (Map.member r (activeConnections st')) $ - modify @RelayPoolState $ \s -> + modify @RelayPool $ \s -> s { activeConnections = Map.adjust (\d -> d { connectionState = Disconnected , lastError = Just $ ConnectionFailed $ T.pack (show e) @@ -169,12 +176,12 @@ connectWithRetry r maxRetries requestChan = do -- | Nostr client for relay connections. -nostrClient :: RelayConnectionEff es => TMVar Bool -> RelayURI -> TChan Request -> (forall a. Eff es a -> IO a) -> WS.ClientApp () +nostrClient :: RelayConnectionEff es => TMVar Bool -> RelayURI -> TChan NT.Request -> (forall a. Eff es a -> IO a) -> WS.ClientApp () nostrClient connectionMVar r requestChan runE conn = runE $ do logDebug $ "Connected to " <> r liftIO $ withPingPong defaultPingPongOptions conn $ \conn' -> runE $ do - modify @RelayPoolState $ \st -> + modify @RelayPool $ \st -> st { activeConnections = Map.adjust (\d -> d { connectionState = Connected , requestChannel = requestChan @@ -184,13 +191,26 @@ nostrClient connectionMVar r requestChan runE conn = runE $ do } notifyRelayStatus + -- Handle pending subscriptions + st <- get @RelayPool + let pendingSubs = pendingSubscriptions st + forM_ (Map.toList pendingSubs) $ \(subId', details) -> do + atomically $ writeTChan requestChan (NT.Subscribe $ NT.Subscription subId' (subscriptionFilter details)) + logDebug $ "Creating subscription from pending for " <> r <> " with subId " <> subId' + + -- Move pending subscriptions to active subscriptions + modify @RelayPool $ \st' -> + st' { subscriptions = Map.union (subscriptions st') pendingSubs + , pendingSubscriptions = Map.empty + } + void $ atomically $ putTMVar connectionMVar True updateQueue <- newTQueueIO receiveThread <- async $ receiveLoop conn' updateQueue sendThread <- async $ sendLoop conn' void $ waitAnyCancel [receiveThread, sendThread] - modify @RelayPoolState $ \st -> + modify @RelayPool $ \st -> st { activeConnections = Map.adjust (\d -> d { connectionState = Disconnected }) r (activeConnections st) } notifyRelayStatus @@ -222,7 +242,7 @@ nostrClient connectionMVar r requestChan runE conn = runE $ do return () Right _ -> do -- Store the event in the state for potential retry - modify @RelayPoolState $ \st -> + modify @RelayPool $ \st -> st { activeConnections = Map.adjust (\rd -> rd { pendingEvents = event : pendingEvents rd }) r @@ -242,23 +262,20 @@ nostrClient connectionMVar r requestChan runE conn = runE $ do handleResponse :: RelayConnectionEff es => RelayURI -> Response -> Eff es UIUpdates handleResponse relayURI' r = case r of EventReceived subId' event' -> do - recordLatestCreatedAt relayURI' event' + recordLatestCreatedAt subId' event' enqueueEvent subId' (EventAppeared event') -- @todo check against filters? return emptyUpdates where - recordLatestCreatedAt :: RelayConnectionEff es => RelayURI -> Event -> Eff es () - recordLatestCreatedAt r' e = do - modify @RelayPoolState $ \st -> st { activeConnections = Map.adjust - (\rd -> rd { activeSubscriptions = Map.adjust + recordLatestCreatedAt :: RelayConnectionEff es => SubscriptionId -> Event -> Eff es () + recordLatestCreatedAt sid e = do + modify @RelayPool $ \st -> st + { subscriptions = Map.adjust (\subDetails -> if createdAt e > newestCreatedAt subDetails - then subDetails { newestCreatedAt = createdAt e } - else subDetails) - subId' - (activeSubscriptions rd) - }) - r' - (activeConnections st) - } + then subDetails { newestCreatedAt = createdAt e } + else subDetails) + sid + (subscriptions st) + } Eose subId' -> do enqueueEvent subId' SubscriptionEose @@ -268,32 +285,25 @@ handleResponse relayURI' r = case r of if "auth-required" `T.isPrefixOf` msg then do -- Queue the subscription for retry after authentication - st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of - Just rd -> - case Map.lookup subId' (activeSubscriptions rd) of - Just subDetails -> do - let subscription = NT.Subscription - { NT.subId = subId' - , NT.filter = subscriptionFilter subDetails - } - handleAuthRequired relayURI' (NT.Subscribe subscription) - Nothing -> logError $ "No subscription found for " <> T.pack (show subId') - Nothing -> logError $ "Received auth-required but no connection found: " <> relayURI' + st <- get @RelayPool + case Map.lookup subId' (subscriptions st) of + Just subDetails -> do + let subscription = NT.Subscription + { NT.subId = subId' + , NT.filter = subscriptionFilter subDetails + } + handleAuthRequired relayURI' (NT.Subscribe subscription) + Nothing -> logError $ "1 No subscription found for " <> T.pack (show subId') else do enqueueEvent subId' (SubscriptionClosed msg) - modify @RelayPoolState $ \st -> - st { activeConnections = Map.adjust - (\rd -> rd { activeSubscriptions = Map.delete subId' (activeSubscriptions rd) }) - relayURI' - (activeConnections st) - } + modify @RelayPool $ \st -> + st { subscriptions = Map.delete subId' (subscriptions st) } return emptyUpdates Ok eventId' accepted' msg -> do if "auth-required" `T.isPrefixOf` msg then do - st <- get @RelayPoolState + st <- get @RelayPool case Map.lookup relayURI' (activeConnections st) of Just rd -> case find (\e -> NT.eventId e == eventId') (pendingEvents rd) of @@ -301,7 +311,7 @@ handleResponse relayURI' r = case r of Nothing -> logDebug $ "No pending event found for " <> T.pack (show eventId') Nothing -> logError $ "Received auth-required but no connection found: " <> relayURI' else do - st <- get @RelayPoolState + st <- get @RelayPool case Map.lookup relayURI' (activeConnections st) of Just rd -> case pendingAuthId rd of @@ -315,7 +325,7 @@ handleResponse relayURI' r = case r of <> " pending events for " <> relayURI' -- Clear pending lists and auth ID - modify @RelayPoolState $ \st' -> + modify @RelayPool $ \st' -> st' { activeConnections = Map.adjust (\rd' -> rd' { pendingRequests = [] , pendingEvents = [] @@ -326,7 +336,7 @@ handleResponse relayURI' r = case r of } -- Retry events and requests - forM_ pendingEvts $ \evt -> atomically $ writeTChan (requestChannel rd) (SendEvent evt) + forM_ pendingEvts $ \evt -> atomically $ writeTChan (requestChannel rd) (NT.SendEvent evt) forM_ pendingReqs $ \req -> atomically $ writeTChan (requestChannel rd) req _ -> logDebug $ "Received OK for event " <> T.pack (show eventId') @@ -335,7 +345,7 @@ handleResponse relayURI' r = case r of return $ emptyUpdates { publishStatusChanged = True } Notice msg -> do - modify @RelayPoolState $ \st -> + modify @RelayPool $ \st -> st { activeConnections = Map.adjust (\rd -> rd { notices = msg : notices rd }) relayURI' @@ -344,7 +354,7 @@ handleResponse relayURI' r = case r of return $ emptyUpdates { noticesChanged = True } Auth challenge -> do - st <- get @RelayPoolState + st <- get @RelayPool case Map.lookup relayURI' (activeConnections st) of Just rd -> do now <- getCurrentTime @@ -353,13 +363,13 @@ handleResponse relayURI' r = case r of signedEventMaybe <- signEvent unsignedEvent kp case signedEventMaybe of Just signedEvent -> do - modify @RelayPoolState $ \st' -> + modify @RelayPool $ \st' -> st' { activeConnections = Map.adjust (\rd' -> rd' { pendingAuthId = Just (eventId signedEvent) }) relayURI' (activeConnections st') } - atomically $ writeTChan (requestChannel rd) (Authenticate signedEvent) + atomically $ writeTChan (requestChannel rd) (NT.Authenticate signedEvent) return emptyUpdates Nothing -> do logError "Failed to sign canonical authentication event" @@ -371,26 +381,24 @@ handleResponse relayURI' r = case r of where enqueueEvent :: RelayConnectionEff es => SubscriptionId -> SubscriptionEvent -> Eff es () enqueueEvent subId' event' = do - st <- get @RelayPoolState - case Map.lookup relayURI' (activeConnections st) of - Just rd -> case Map.lookup subId' (activeSubscriptions rd) of - Just sd -> atomically $ writeTQueue (responseQueue sd) event' - Nothing -> error $ "No subscription found for " <> show subId' - Nothing -> error $ "No connection found for " <> show relayURI' + st <- get @RelayPool + case Map.lookup subId' (subscriptions st) of + Just sd -> atomically $ writeTQueue (responseQueue sd) (relayURI', event') + Nothing -> error $ "2 No subscription found for " <> show subId' <> " with response: " <> show r -- | Handle authentication required. -handleAuthRequired :: RelayConnectionEff es => RelayURI -> Request -> Eff es () +handleAuthRequired :: RelayConnectionEff es => RelayURI -> NT.Request -> Eff es () handleAuthRequired relayURI' request = case request of - SendEvent evt -> do - modify @RelayPoolState $ \st' -> + NT.SendEvent evt -> do + modify @RelayPool $ \st' -> st' { activeConnections = Map.adjust (\rd' -> rd' { pendingEvents = evt : pendingEvents rd' }) relayURI' (activeConnections st') } _ -> do - modify @RelayPoolState $ \st' -> + modify @RelayPool $ \st' -> st' { activeConnections = Map.adjust (\rd' -> rd' { pendingRequests = request : pendingRequests rd' }) relayURI' diff --git a/src/Nostr/RelayPool.hs b/src/Nostr/RelayPool.hs deleted file mode 100644 index ec5cf2a..0000000 --- a/src/Nostr/RelayPool.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE BlockArguments #-} - -module Nostr.RelayPool where - -import Control.Monad (forM_, when) -import Data.Map.Strict qualified as Map -import Effectful -import Effectful.Concurrent (Concurrent, threadDelay) -import Effectful.Dispatch.Dynamic (interpret) -import Effectful.State.Static.Shared (State, get) -import Effectful.TH - -import KeyMgmt (KeyMgmt) -import Logging -import Nostr -import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) -import Nostr.Publisher -import Nostr.RelayConnection -import Nostr.Subscription -import Nostr.Types (Event(..), Kind(..), Relay(..), RelayURI) -import Nostr.Util -import QtQuick -import RelayMgmt (RelayMgmt) -import RelayMgmt qualified as RM -import Store.Lmdb (LmdbStore) -import Types (AppState(..), ConnectionState(..), RelayData(..), RelayPoolState(..)) - - --- | Disconnect reason. -data DisconnectReason = UserInitiated | ConnectionFailure - deriving (Show, Eq) - - --- | Effect for handling RelayPool operations. -data RelayPool :: Effect where - -- General Relay Management - ImportGeneralRelays :: PubKeyXO -> [Relay] -> Int -> RelayPool m () - AddGeneralRelay :: PubKeyXO -> RelayURI -> Bool -> Bool -> RelayPool m Bool - RemoveGeneralRelay :: PubKeyXO -> RelayURI -> RelayPool m () - GetGeneralRelays :: PubKeyXO -> RelayPool m ([(Relay, ConnectionState)], Int) - -- DM Relay Management - ImportDMRelays :: PubKeyXO -> [Relay] -> Int -> RelayPool m () - AddDMRelay :: PubKeyXO -> RelayURI -> RelayPool m Bool - RemoveDMRelay :: PubKeyXO -> RelayURI -> RelayPool m () - GetDMRelays :: PubKeyXO -> RelayPool m ([(Relay, ConnectionState)], Int) - -- Connection Management - Connect :: RelayURI -> RelayPool m () - Disconnect :: RelayURI -> RelayPool m () - DisconnectAll :: RelayPool m () - AwaitAtLeastOneConnected :: RelayPool m Bool - -- Event Operations - SendEvent :: Event -> RelayPool m () - -type instance DispatchOf RelayPool = Dynamic - -makeEffect ''RelayPool - - --- | RelayPoolEff -type RelayPoolEff es = - ( State AppState :> es - , State RelayPoolState :> es - , LmdbStore :> es - , Nostr :> es - , RelayConnection :> es - , Publisher :> es - , RelayMgmt :> es - , Subscription :> es - , KeyMgmt :> es - , QtQuick :> es - , Concurrent :> es - , Logging :> es - , Util :> es - , IOE :> es - ) - - --- | Handler for relay pool effects. -runRelayPool - :: RelayPoolEff es - => Eff (RelayPool : es) a - -> Eff es a -runRelayPool = interpret $ \_ -> \case - ImportGeneralRelays pk rs ts -> RM.importGeneralRelays pk rs ts - - AddGeneralRelay pk relay' r w -> RM.addGeneralRelay pk relay' r w - - RemoveGeneralRelay pk r -> RM.removeGeneralRelay pk r - - GetGeneralRelays pk -> RM.getGeneralRelays pk - - ImportDMRelays pk rs ts -> RM.importDMRelays pk rs ts - - AddDMRelay pk r -> RM.addDMRelay pk r - - RemoveDMRelay pk r -> RM.removeDMRelay pk r - - GetDMRelays pk -> RM.getDMRelays pk - - Connect r -> do - res <- connectRelay r - when res $ handleRelaySubscription r - - Nostr.RelayPool.Disconnect r -> disconnectRelay r - - DisconnectAll -> do - st <- get @RelayPoolState - forM_ (Map.toList $ activeConnections st) $ \(r, _) -> disconnectRelay r - - AwaitAtLeastOneConnected -> do - let loop = do - st <- get @RelayPoolState - let states = map (connectionState . snd) $ Map.toList $ activeConnections st - if any (== Connected) states - then return True - else if null states - then return False - else if all (== Disconnected) states - then return False - else do - threadDelay 50000 -- 50ms delay - loop - loop - - Nostr.RelayPool.SendEvent event -> do - kp <- getKeyPair - let pk = keyPairToPubKeyXO kp - - case kind event of - -- Events that should be broadcast to all relays - PreferredDMRelays -> broadcast event - RelayListMetadata -> broadcast event - Metadata -> broadcast event - -- Gift wrap events need special handling for DM relays - GiftWrap -> publishGiftWrap event pk - -- Default case: publish to outbox-capable relays (FollowList, ShortTextNote, etc.) - _ -> publishToOutbox event diff --git a/src/Nostr/Subscription.hs b/src/Nostr/Subscription.hs index cafba2e..f606def 100644 --- a/src/Nostr/Subscription.hs +++ b/src/Nostr/Subscription.hs @@ -15,7 +15,7 @@ import Effectful import Effectful.Concurrent import Effectful.Concurrent.Async (async) import Effectful.Concurrent.STM ( TQueue, atomically, flushTQueue, newTQueueIO, newTVarIO - , readTQueue, readTVar, tryReadTQueue, writeTChan, writeTVar ) + , readTQueue, readTVar, tryReadTQueue, writeTChan, writeTQueue, writeTVar ) import Effectful.Dispatch.Dynamic (interpret) import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH @@ -24,14 +24,14 @@ import System.Random (randomIO) import QtQuick -import KeyMgmt (AccountId(..), KeyMgmt, updateProfile, updateRelays) +import KeyMgmt (AccountId(..), KeyMgmt, updateProfile) import Logging import Nostr.Bech32 (pubKeyXOToBech32) import Nostr.Event (validateEvent) import Nostr.Keys (PubKeyXO, byteStringToHex, exportPubKeyXO, keyPairToPubKeyXO) import Nostr.RelayConnection import Nostr.Types ( Event(..), EventId(..), Filter(..), Kind(..), Relay(..) - , RelayURI, SubscriptionId, Tag(..), emptyFilter, getUri ) + , RelayURI, SubscriptionId, Tag(..), emptyFilter, getUri, isValidRelayURI ) import Nostr.Types qualified as NT import Nostr.Util import RelayMgmt @@ -41,10 +41,14 @@ import Types -- | Subscription effects data Subscription :: Effect where - NewSubscriptionId :: Subscription m SubscriptionId - Subscribe :: RelayURI -> SubscriptionId -> Filter -> Subscription m (Maybe (TQueue SubscriptionEvent)) + Subscribe + :: RelayURI + -> Filter + -> TQueue (RelayURI, SubscriptionEvent) + -> Subscription m SubscriptionId StopSubscription :: SubscriptionId -> Subscription m () - HandleEvent :: RelayURI -> SubscriptionId -> Filter -> Event -> Subscription m UIUpdates + HandleEvent :: RelayURI -> Event -> Subscription m UIUpdates + StopAllSubscriptions :: RelayURI -> Subscription m () type instance DispatchOf Subscription = Dynamic @@ -54,7 +58,7 @@ makeEffect ''Subscription -- | SubscriptionEff type SubscriptionEff es = ( State AppState :> es - , State RelayPoolState :> es + , State RelayPool :> es , LmdbStore :> es , RelayConnection :> es , KeyMgmt :> es @@ -72,264 +76,154 @@ runSubscription => Eff (Subscription : es) a -> Eff es a runSubscription = interpret $ \_ -> \case - NewSubscriptionId -> generateRandomSubscriptionId - - Subscribe r subId' f -> createSubscription r subId' f + Subscribe r f queue -> do + subId' <- generateRandomSubscriptionId + let sub = SubscriptionDetails subId' f queue 0 0 r + st <- get @RelayPool + case Map.lookup r (activeConnections st) of + Just rd -> do + let channel = requestChannel rd + modify @RelayPool $ \st' -> + st' { subscriptions = Map.insert subId' sub (subscriptions st') } + atomically $ writeTChan channel (NT.Subscribe $ NT.Subscription subId' f) + logDebug $ "Subscribed to " <> r <> " with subId " <> subId' <> " and filter " <> pack (show f) + return subId' + Nothing -> do + modify @RelayPool $ \st' -> + st' { pendingSubscriptions = Map.insert subId' sub (pendingSubscriptions st') } + logDebug $ "Added pending subscription for " <> r <> " with subId " <> subId' <> " and filter " <> pack (show f) + return subId' StopSubscription subId' -> do - st <- get @RelayPoolState - forM_ (Map.toList $ activeConnections st) $ \(r, rd) -> do - case Map.lookup subId' (activeSubscriptions rd) of - Just _ -> do - atomically $ writeTChan (requestChannel rd) (NT.Close subId') - modify @RelayPoolState $ \s -> s - { activeConnections = Map.adjust - (\rd' -> rd' { activeSubscriptions = Map.delete subId' (activeSubscriptions rd') }) - r - (activeConnections s) - } - Nothing -> return () - - HandleEvent r _ _ event' -> handleEvent' event' r - - -handleEvent' :: SubscriptionEff es => Event -> RelayURI -> Eff es UIUpdates -handleEvent' event' r = do - --logDebug $ "Starting handleEvent' for event: " <> pack (show event') - let ev = EventWithRelays event' (Set.singleton r) - - if not (validateEvent event') - then do - logWarning $ "Invalid event seen: " <> (byteStringToHex $ getEventId (eventId event')) - pure emptyUpdates - else do - putEvent ev - updates <- case kind event' of - ShortTextNote -> - pure $ emptyUpdates { postsChanged = True } - - Repost -> - case ([t | t@(ETag _ _ _) <- tags event'], eitherDecode (fromStrict $ encodeUtf8 $ content event')) of - (ETag eid _ _:_, Right originalEvent) | validateEvent originalEvent -> - pure $ emptyUpdates { postsChanged = True } - _ -> do - logWarning $ "Invalid repost or missing e-tag: " <> (byteStringToHex $ getEventId (eventId event')) - pure emptyUpdates - - EventDeletion -> - pure $ emptyUpdates { postsChanged = True, privateMessagesChanged = True } - - Metadata -> do - case eitherDecode (fromStrict $ encodeUtf8 $ content event') of - Right profile -> do - st <- get @AppState - let isOwnProfile = maybe False (\kp -> pubKey event' == keyPairToPubKeyXO kp) (keyPair st) - when isOwnProfile $ do - let aid = AccountId $ pubKeyXOToBech32 (pubKey event') - updateProfile aid profile - pure $ emptyUpdates { profilesChanged = True } - Left err -> do - logWarning $ "Failed to decode metadata: " <> pack err - pure emptyUpdates - - FollowList -> - pure $ emptyUpdates { followsChanged = True } - - GiftWrap -> do - pure $ emptyUpdates { privateMessagesChanged = True } - - RelayListMetadata -> do - let validRelayTags = [ r' | RelayTag r' <- tags event', isValidRelayURI (getUri r') ] - case validRelayTags of - [] -> do - logWarning $ "No valid relay URIs found in RelayListMetadata event from " - <> (pubKeyXOToBech32 $ pubKey event') - pure emptyUpdates - relays -> do - handleRelayListUpdate (pubKey event') relays (createdAt event') - importGeneralRelays - generalRelays - pure $ emptyUpdates { generalRelaysChanged = True } - - PreferredDMRelays -> do - let validRelayTags = [ r' | RelayTag r' <- tags event', isValidRelayURI (getUri r') ] - case validRelayTags of - [] -> do - logWarning $ "No valid relay URIs found in PreferredDMRelays event from " - <> (pubKeyXOToBech32 $ pubKey event') - pure emptyUpdates - relays -> do - handleRelayListUpdate (pubKey event') relays (createdAt event') - importDMRelays - dmRelays - pure $ emptyUpdates { dmRelaysChanged = True } - - _ -> do - logDebug $ "Ignoring event of kind: " <> pack (show (kind event')) - pure emptyUpdates - --logDebug $ "Finished handleEvent' for event: " <> pack (show event') - pure updates - where - isValidRelayURI :: RelayURI -> Bool - isValidRelayURI uriText = - case parseURI (unpack uriText) of - Just uri -> - let scheme = uriScheme uri - authority = uriAuthority uri - in (scheme == "ws:" || scheme == "wss:") && - maybe False (not . null . uriRegName) authority - Nothing -> False - - --- | Create a subscription -createSubscription :: SubscriptionEff es - => RelayURI - -> SubscriptionId - -> Filter - -> Eff es (Maybe (TQueue SubscriptionEvent)) -createSubscription r subId' f = do - st <- get @RelayPoolState - case Map.lookup r (activeConnections st) of - Just rd -> do - let channel = requestChannel rd - atomically $ writeTChan channel (NT.Subscribe $ NT.Subscription subId' f) - logDebug $ "Subscribed to " <> r <> " with subId " <> subId' <> " and filter " <> pack (show f) - q <- newTQueueIO - modify @RelayPoolState $ \st' -> - st { activeConnections = Map.adjust - (\rd' -> rd' { activeSubscriptions = Map.insert subId' (SubscriptionDetails subId' f q 0 0) (activeSubscriptions rd') }) - r - (activeConnections st') - } - return $ pure q - Nothing -> do - logWarning $ "Cannot start subscription: no connection found for relay: " <> r - return Nothing - - --- | Determine relay type and start appropriate subscriptions -handleRelaySubscription :: SubscriptionEff es => RelayURI -> Eff es () -handleRelaySubscription r = do - kp <- getKeyPair - let pk = keyPairToPubKeyXO kp - follows <- getFollows pk - let followPks = map pubkey follows - st' <- get @RelayPoolState - - -- Check if it's a DM relay - let isDM = any (\(_, (relays, _)) -> - any (\relay -> getUri relay == r) relays) - (Map.toList $ dmRelays st') - - -- Check if it's an inbox-capable relay - let isInbox = any (\(_, (relays, _)) -> - any (\relay -> case relay of - InboxRelay uri -> uri == r - InboxOutboxRelay uri -> uri == r - _ -> False) relays) - (Map.toList $ generalRelays st') - - -- Start appropriate subscriptions based on relay type - let f = if isDM - then Just $ giftWrapFilter pk - else if isInbox - then Just $ createInboxRelayFilter pk followPks - else Nothing - - --logInfo $ "Starting subscription for " <> r <> " with filter " <> pack (show fs) - - case f of - Just f' -> do - subId' <- generateRandomSubscriptionId - mq <- createSubscription r subId' f' - case mq of - Just q -> do - shouldStop <- newTVarIO False - - let loop = do - e <- atomically $ readTQueue q - es <- atomically $ flushTQueue q - - updates <- fmap mconcat $ forM (e : es) $ \case - EventAppeared event' -> handleEvent' event' r - SubscriptionEose -> return emptyUpdates - SubscriptionClosed _ -> do - atomically $ writeTVar shouldStop True - return emptyUpdates - - notify updates - - shouldStopNow <- atomically $ readTVar shouldStop - - if shouldStopNow - then return () - else loop - - loop - Nothing -> logWarning $ "Failed to start subscription for " <> r - Nothing -> return () -- Outbox only relay or unknown relay, no subscriptions needed - - --- | Handle relay list updates with connection management -handleRelayListUpdate :: SubscriptionEff es - => PubKeyXO -- ^ Public key of the event author - -> [Relay] -- ^ New relay list - -> Int -- ^ Event timestamp - -> (PubKeyXO -> [Relay] -> Int -> Eff es ()) -- ^ Import function - -> (RelayPoolState -> Map.Map PubKeyXO ([Relay], Int)) -- ^ Relay map selector - -> Eff es () -handleRelayListUpdate pk relays ts importFn getRelayMap = do - st <- get @RelayPoolState - let currentMap = getRelayMap st - let (currentRelays, currentTs) = Map.findWithDefault ([], 0) pk currentMap - - when (ts > currentTs) $ do - -- Log what we're doing - logDebug $ "Updating relays for " <> pubKeyXOToBech32 pk - <> " from " <> pack (show currentRelays) - <> " to " <> pack (show relays) - <> " (map: " <> pack (show $ Map.keys currentMap) <> ")" - - -- Disconnect from removed relays - let removedRelays = filter (\r -> not $ any (\r' -> getUri r == getUri r') relays) currentRelays - forM_ removedRelays $ \relay -> do - logDebug $ "Disconnecting from removed relay: " <> pack (show (getUri relay)) - disconnectRelay (getUri relay) - - -- Import new configuration - importFn pk relays ts - - -- Connect to new relays - let newRelays = filter (\r -> not $ any (\r' -> getUri r == getUri r') currentRelays) relays - forM_ newRelays $ \relay -> do - logDebug $ "Connecting to new relay: " <> pack (show (getUri relay)) - void $ async $ connectRelay (getUri relay) - - --- | Create DM relay subscription filter -createDMRelayFilter :: PubKeyXO -> [PubKeyXO] -> Filter -createDMRelayFilter xo followedPubKeys = giftWrapFilter xo - - --- | Create inbox relay subscription filter -createInboxRelayFilter :: PubKeyXO -> [PubKeyXO] -> Filter -createInboxRelayFilter xo followedPubKeys = - {- - [ NT.followListFilter (xo : followedPubKeys) - , NT.metadataFilter (xo : followedPubKeys) - , NT.shortTextNoteFilter (xo : followedPubKeys) - , NT.preferredDMRelaysFilter (xo : followedPubKeys) - ] - -} - Filter - { ids = Nothing - , authors = Just (xo : followedPubKeys) - , kinds = Just [FollowList, Metadata, ShortTextNote, EventDeletion, Repost, PreferredDMRelays] - , since = Nothing - , NT.until = Nothing - , limit = Just 1000 - , fTags = Nothing - } + st <- get @RelayPool + + case Map.lookup subId' (subscriptions st) of + Just subDetails -> do + case Map.lookup (relay subDetails) (activeConnections st) of + Just rd -> atomically $ writeTChan (requestChannel rd) (NT.Close subId') + Nothing -> pure () + Nothing -> pure () + + case Map.lookup subId' (pendingSubscriptions st) of + Just subDetails -> + atomically $ writeTQueue (responseQueue subDetails) (relay subDetails, SubscriptionClosed "Subscription stopped") + Nothing -> pure () + + modify @RelayPool $ \s -> s + { subscriptions = Map.delete subId' (subscriptions s) + , pendingSubscriptions = Map.delete subId' (pendingSubscriptions s) + } + + HandleEvent r event' -> do + --logDebug $ "Starting handleEvent' for event: " <> pack (show event') + let ev = EventWithRelays event' (Set.singleton r) + + if not (validateEvent event') + then do + logWarning $ "Invalid event seen: " <> (byteStringToHex $ getEventId (eventId event')) + pure emptyUpdates + else do + wasUpdated <- putEvent ev + updates <- case kind event' of + ShortTextNote -> + pure $ emptyUpdates { postsChanged = wasUpdated } + + Repost -> + case ([t | t@(ETag _ _ _) <- tags event'], eitherDecode (fromStrict $ encodeUtf8 $ content event')) of + (ETag eid _ _:_, Right originalEvent) | validateEvent originalEvent -> + pure $ emptyUpdates { postsChanged = wasUpdated } + _ -> do + logWarning $ "Invalid repost or missing e-tag: " <> (byteStringToHex $ getEventId (eventId event')) + pure emptyUpdates + + EventDeletion -> + pure $ emptyUpdates { postsChanged = wasUpdated, privateMessagesChanged = wasUpdated } + + Metadata -> do + case eitherDecode (fromStrict $ encodeUtf8 $ content event') of + Right profile -> do + st <- get @AppState + let isOwnProfile = maybe False (\kp -> pubKey event' == keyPairToPubKeyXO kp) (keyPair st) + when isOwnProfile $ do + let aid = AccountId $ pubKeyXOToBech32 (pubKey event') + updateProfile aid profile + pure $ emptyUpdates { profilesChanged = wasUpdated } + Left err -> do + logWarning $ "Failed to decode metadata: " <> pack err + pure emptyUpdates + + FollowList -> do + kp <- getKeyPair + let pk = keyPairToPubKeyXO kp + pure $ emptyUpdates { followsChanged = wasUpdated, myFollowsChanged = wasUpdated && pk == pubKey event' } + + GiftWrap -> do + pure $ emptyUpdates { privateMessagesChanged = wasUpdated } + + RelayListMetadata -> do + let validRelayTags = [ r' | RTag r' <- tags event', isValidRelayURI (getUri r') ] + case validRelayTags of + [] -> do + logWarning $ "No valid relay URIs found in RelayListMetadata event from " + <> (pubKeyXOToBech32 $ pubKey event') + logWarning $ "Event: " <> pack (show event') + pure emptyUpdates + relays -> do + {- @todo: handle relay list update + handleRelayListUpdate (pubKey event') relays (createdAt event') + importGeneralRelays + generalRelays + -} + pure $ emptyUpdates { generalRelaysChanged = wasUpdated } + + PreferredDMRelays -> do + let validRelayTags = [ r' | RelayTag r' <- tags event', isValidRelayURI r' ] + case validRelayTags of + [] -> do + logWarning $ "No valid relay URIs found in PreferredDMRelays event from " + <> (pubKeyXOToBech32 $ pubKey event') + logWarning $ "Event: " <> pack (show event') + pure emptyUpdates + relays -> do + {- @todo: handle relay list update + handleRelayListUpdate (pubKey event') relays (createdAt event') + importDMRelays + dmRelays + -} + pure $ emptyUpdates { dmRelaysChanged = wasUpdated } + + _ -> do + logDebug $ "Ignoring event of kind: " <> pack (show (kind event')) + pure emptyUpdates + --logDebug $ "Finished handleEvent' for event: " <> pack (show event') + pure updates + + StopAllSubscriptions relayUri -> do + st <- get @RelayPool + case Map.lookup relayUri (activeConnections st) of + Just rd -> do + let relaySubIds = [ subId + | (subId, subDetails) <- Map.toList (subscriptions st) + , relay subDetails == relayUri + ] + + forM_ relaySubIds $ \subId -> do + atomically $ writeTChan (requestChannel rd) (NT.Close subId) + Nothing -> return () + + let affectedPendingSubs = [ subDetails + | (_, subDetails) <- Map.toList (pendingSubscriptions st) + , relay subDetails == relayUri + ] + + forM_ affectedPendingSubs $ \subDetails -> + atomically $ writeTQueue (responseQueue subDetails) (relay subDetails, SubscriptionClosed "Subscription stopped") + + modify @RelayPool $ \s -> s + { subscriptions = Map.filterWithKey (\k v -> relay v /= relayUri) (subscriptions s) + , pendingSubscriptions = Map.filterWithKey (\k v -> relay v /= relayUri) (pendingSubscriptions s) + } + -- | Generate a random subscription ID generateRandomSubscriptionId :: SubscriptionEff es => Eff es SubscriptionId @@ -338,75 +232,61 @@ generateRandomSubscriptionId = do let byteString = BS.pack bytes return $ decodeUtf8 $ B16.encode byteString --- | Subscribe to reactions for a specific event -subscribeToReactions :: SubscriptionEff es => EventId -> RelayURI -> Eff es (Maybe (TQueue SubscriptionEvent)) -subscribeToReactions eid relayUri = do - subId <- generateRandomSubscriptionId - createSubscription relayUri subId (reactionsFilter eid) - - --- | Subscribe to reposts for a specific event -subscribeToReposts :: SubscriptionEff es => EventId -> RelayURI -> Eff es (Maybe (TQueue SubscriptionEvent)) -subscribeToReposts eid relayUri = do - subId <- generateRandomSubscriptionId - createSubscription relayUri subId (repostsFilter eid) - - --- | Subscribe to comments for a specific event -subscribeToComments :: SubscriptionEff es => EventId -> RelayURI -> Eff es (Maybe (TQueue SubscriptionEvent)) -subscribeToComments eid relayUri = do - subId <- generateRandomSubscriptionId - createSubscription relayUri subId (commentsFilter eid) - -subscribeToFollowers :: SubscriptionEff es => PubKeyXO -> RelayURI -> Eff es (Maybe (TQueue SubscriptionEvent)) -subscribeToFollowers xo relayUri = do - subId <- generateRandomSubscriptionId - createSubscription relayUri subId (followersFilter xo) - - -subscribeToFollowing :: SubscriptionEff es => PubKeyXO -> RelayURI -> Eff es (Maybe (TQueue SubscriptionEvent)) -subscribeToFollowing xo relayUri = do - subId <- generateRandomSubscriptionId - createSubscription relayUri subId (followingFilter xo) +-- Helper functions to create specific filters --- Helper function to count events from a subscription -countEvents :: SubscriptionEff es => TQueue SubscriptionEvent -> Eff es Int -countEvents queue = do - event <- atomically $ tryReadTQueue queue - case event of - Just (EventAppeared _) -> (1 +) <$> countEvents queue - Just SubscriptionEose -> return 0 - Nothing -> return 0 +-- | Creates a filter for fetching profile-related metadata events. +-- +-- This filter targets three key event kinds: +-- * RelayListMetadata (Kind 10002) - User's preferred general-purpose relays +-- * PreferredDMRelays (Kind 10003) - User's preferred DM relays +-- * FollowList (Kind 3) - User's list of followed pubkeys +profilesFilter :: [PubKeyXO] -> Maybe Int -> Filter +profilesFilter authors lastTimestamp = emptyFilter + { authors = Just authors + , kinds = Just [RelayListMetadata, PreferredDMRelays, FollowList] + , since = lastTimestamp + } + + +-- | Creates a filter for fetching a user's public posts and interactions. +-- +-- This filter targets three event kinds: +-- * ShortTextNote - User's regular posts +-- * Repost - Content the user has reposted +-- * Comment - User's replies to other posts +userPostsFilter :: [PubKeyXO] -> Maybe Int -> Filter +userPostsFilter authors lastTimestamp = emptyFilter + { authors = Just authors + , kinds = Just [ShortTextNote, Repost, EventDeletion] + , since = lastTimestamp + } --- Helper functions to create specific filters - -- | Creates a filter for metadata. metadataFilter :: [PubKeyXO] -> Filter -metadataFilter authors = emptyFilter { authors = Just authors, kinds = Just [Metadata], limit = Just 500 } +metadataFilter authors = emptyFilter { authors = Just authors, kinds = Just [Metadata] } -- | Creates a filter for short text notes. shortTextNoteFilter :: [PubKeyXO] -> Filter -shortTextNoteFilter authors = emptyFilter { authors = Just authors, kinds = Just [ShortTextNote, EventDeletion, Repost], limit = Just 500 } +shortTextNoteFilter authors = emptyFilter { authors = Just authors, kinds = Just [ShortTextNote, EventDeletion, Repost] } -- | Creates filter for gift wrapped messages. -giftWrapFilter :: PubKeyXO -> Filter -giftWrapFilter xo = emptyFilter { kinds = Just [GiftWrap], fTags = Just $ Map.fromList [('p', [byteStringToHex $ exportPubKeyXO xo])], limit = Just 500 } +giftWrapFilter :: PubKeyXO -> Maybe Int -> Filter +giftWrapFilter xo lastTimestamp = emptyFilter { kinds = Just [GiftWrap], fTags = Just $ Map.fromList [('p', [byteStringToHex $ exportPubKeyXO xo])], since = lastTimestamp } -- | Creates a filter for preferred DM relays. preferredDMRelaysFilter :: [PubKeyXO] -> Filter -preferredDMRelaysFilter authors = emptyFilter { authors = Just authors, kinds = Just [PreferredDMRelays], limit = Just 500 } +preferredDMRelaysFilter authors = emptyFilter { authors = Just authors, kinds = Just [PreferredDMRelays] } + +relayListMetadataFilter :: [PubKeyXO] -> Filter +relayListMetadataFilter authors = emptyFilter { authors = Just authors, kinds = Just [RelayListMetadata] } -- | Creates a filter for a specific event by its ID. eventFilter :: EventId -> Filter eventFilter eid = emptyFilter { ids = Just [eid] } --- | Filter for reactions (likes) to a specific event. -reactionsFilter :: EventId -> Filter -reactionsFilter eid = emptyFilter { kinds = Just [Reaction], fTags = Just $ Map.singleton 'e' [decodeUtf8 $ B16.encode $ getEventId eid] } - -- | Filter for reposts of a specific event. repostsFilter :: EventId -> Filter repostsFilter eid = emptyFilter { kinds = Just [Repost], fTags = Just $ Map.singleton 'e' [decodeUtf8 $ B16.encode $ getEventId eid] } @@ -423,6 +303,9 @@ followersFilter pubkey = emptyFilter { kinds = Just [FollowList], fTags = Just $ followingFilter :: PubKeyXO -> Filter followingFilter pubkey = emptyFilter { authors = Just [pubkey], kinds = Just [FollowList] } --- | Filter for posts made by a specific public key. -postsFilter :: PubKeyXO -> Filter -postsFilter pubkey = emptyFilter { authors = Just [pubkey], kinds = Just [ShortTextNote, Repost, Comment] } +-- | Filter for mentions of a specific public key. +mentionsFilter :: PubKeyXO -> Maybe Int ->Filter +mentionsFilter pubkey ts = emptyFilter + { kinds = Just [ShortTextNote, Repost, Comment, EventDeletion] + , fTags = Just $ Map.singleton 'p' [byteStringToHex $ exportPubKeyXO pubkey] + , since = ts } diff --git a/src/Nostr/Types.hs b/src/Nostr/Types.hs index 23cb258..c94a961 100644 --- a/src/Nostr/Types.hs +++ b/src/Nostr/Types.hs @@ -28,6 +28,7 @@ import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8) import Data.Vector qualified as V import GHC.Generics (Generic) +import Network.URI (URI(..), parseURI, uriAuthority, uriRegName, uriScheme) import Prelude hiding (until) import Text.Read (readMaybe) @@ -50,13 +51,6 @@ instance Ord Relay where compare r r' = compare (getUri r) (getUri r') --- | Get the URI from a Relay -getUri :: Relay -> RelayURI -getUri (InboxRelay uri) = uri -getUri (OutboxRelay uri) = uri -getUri (InboxOutboxRelay uri) = uri - - -- | Instance for converting a 'Relay' to JSON. instance ToJSON Relay where toEncoding relay = case relay of @@ -78,6 +72,40 @@ instance FromJSON Relay where _ -> fail "Invalid relay format" + +-- | Get the URI from a Relay +getUri :: Relay -> RelayURI +getUri (InboxRelay uri) = uri +getUri (OutboxRelay uri) = uri +getUri (InboxOutboxRelay uri) = uri + + +-- | Check if a relay is inbox capable +isInboxCapable :: Relay -> Bool +isInboxCapable (InboxRelay _) = True +isInboxCapable (InboxOutboxRelay _) = True +isInboxCapable (OutboxRelay _) = False + + +-- | Check if a relay is outbox capable +isOutboxCapable :: Relay -> Bool +isOutboxCapable (OutboxRelay _) = True +isOutboxCapable (InboxOutboxRelay _) = True +isOutboxCapable (InboxRelay _) = False + + +-- | Check if a relay URI is valid +isValidRelayURI :: RelayURI -> Bool +isValidRelayURI uriText = + case parseURI (T.unpack uriText) of + Just uri -> + let scheme = uriScheme uri + authority = uriAuthority uri + in (scheme == "ws:" || scheme == "wss:") && + maybe False (not . null . uriRegName) authority + Nothing -> False + + -- | Represents a subscription id as text. type SubscriptionId = Text @@ -162,6 +190,28 @@ data Kind deriving (Eq, Generic, Read, Show) +instance Ord Kind where + compare k1 k2 = compare (kindToInt k1) (kindToInt k2) + where + kindToInt :: Kind -> Int + kindToInt = \case + Metadata -> 0 + ShortTextNote -> 1 + FollowList -> 3 + EventDeletion -> 5 + Repost -> 6 + Reaction -> 7 + GenericRepost -> 16 + Seal -> 13 + GiftWrap -> 1059 + DirectMessage -> 14 + PreferredDMRelays -> 10050 + CanonicalAuthentication -> 22242 + RelayListMetadata -> 10002 + Comment -> 1111 + UnknownKind n -> n + + -- | Represents an event id as a byte string. newtype EventId = EventId { getEventId :: ByteString } deriving (Eq, Ord) @@ -191,7 +241,8 @@ data Tag | PTag PubKeyXO (Maybe RelayURI) (Maybe DisplayName) | QTag EventId (Maybe RelayURI) (Maybe PubKeyXO) | KTag Text - | RelayTag Relay + | RTag Relay + | RelayTag RelayURI | ChallengeTag Text | ITag ExternalId (Maybe Text) | GenericTag [Value] @@ -400,6 +451,7 @@ instance FromJSON Tag where ("q":rest) -> parseQTag rest v ("i":rest) -> parseITag rest v ("k":rest) -> parseKTag rest v + ("r":rest) -> parseRTag rest v ("relay":rest) -> parseRelayTag rest v ("challenge":rest) -> parseChallengeTag rest v _ -> parseGenericTag v @@ -471,19 +523,27 @@ parseMaybeDisplayName v = fail $ "Expected string for display name, got: " ++ sh -- | Parses a relay tag from a JSON array. -parseRelayTag :: [Value] -> Value -> Parser Tag -parseRelayTag rest _ = case rest of +parseRTag :: [Value] -> Value -> Parser Tag +parseRTag rest _ = case rest of [relayVal, markerVal] -> do relayURI' <- parseRelayURI relayVal marker <- parseJSON markerVal :: Parser Text case T.toLower marker of - "write" -> return $ RelayTag (OutboxRelay relayURI') - "read" -> return $ RelayTag (InboxRelay relayURI') - _ -> fail "Invalid RelayTag marker" + "write" -> return $ RTag (OutboxRelay relayURI') + "read" -> return $ RTag (InboxRelay relayURI') + _ -> fail "Invalid RTag marker" + [relayVal] -> do + relayURI' <- parseRelayURI relayVal + return $ RTag (InboxOutboxRelay relayURI') + _ -> fail "Invalid RTag format" + +-- | Parses a relay tag from a JSON array. +parseRelayTag :: [Value] -> Value -> Parser Tag +parseRelayTag rest _ = case rest of [relayVal] -> do relayURI' <- parseRelayURI relayVal - return $ RelayTag (InboxOutboxRelay relayURI') - _ -> fail "Invalid RelayTag format" + return $ RelayTag relayURI' + _ -> fail "Invalid relay tag format. Expected single relay URI." -- | Parses a RelayURI from a JSON value. @@ -543,11 +603,12 @@ instance ToJSON Tag where maybe [] (\url -> [text url]) urlHint KTag kind -> list id [ text "k", text kind ] - RelayTag relay -> + RTag relay -> list id $ case relay of - InboxRelay uri -> [text "relay", text uri, text "read"] - OutboxRelay uri -> [text "relay", text uri, text "write"] - InboxOutboxRelay uri -> [text "relay", text uri] + InboxRelay uri -> [text "r", text uri, text "read"] + OutboxRelay uri -> [text "r", text uri, text "write"] + InboxOutboxRelay uri -> [text "r", text uri] + RelayTag relayUri -> list id $ [text "relay", text relayUri] ChallengeTag challenge -> list id [text "challenge", text challenge] GenericTag values -> list toEncoding values @@ -697,19 +758,20 @@ instance FromJSON Profile where -- | Provides a default list of general relays. defaultGeneralRelays :: ([Relay], Int) defaultGeneralRelays = - ( [ InboxRelay "wss://nos.lol" + ( [ InboxOutboxRelay "wss://nos.lol" , InboxOutboxRelay "wss://relay.nostr.bg" , InboxOutboxRelay "wss://nostr.mom" , InboxOutboxRelay "wss://offchain.pub" + , InboxRelay "wss://relay.damus.io" ], 0 ) -- | Provides a default list of DM relays. -defaultDMRelays :: ([Relay], Int) +defaultDMRelays :: ([RelayURI], Int) defaultDMRelays = - ( [ InboxOutboxRelay "wss://auth.nostr1.com" ], 0 ) + ( [ "wss://auth.nostr1.com" ], 0 ) -- | Extracts the scheme of a relay's URI. diff --git a/src/Presentation/KeyMgmtUI.hs b/src/Presentation/KeyMgmtUI.hs index 931e6cf..4e86619 100644 --- a/src/Presentation/KeyMgmtUI.hs +++ b/src/Presentation/KeyMgmtUI.hs @@ -6,34 +6,41 @@ module Presentation.KeyMgmtUI where -import Control.Monad (forM_, void, when) import Data.Map.Strict qualified as Map import Data.Text (Text) import Effectful import Effectful.Concurrent -import Effectful.Concurrent.Async (async) import Effectful.Dispatch.Dynamic (EffectHandler, interpret) import Effectful.FileSystem (FileSystem) import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH import Graphics.QML hiding (fireSignal, runEngineLoop) -import System.Random.Shuffle (shuffleM) import QtQuick import KeyMgmt import Logging import Nostr import Nostr.Bech32 -import Nostr.Event (createPreferredDMRelaysEvent, createRelayListMetadataEvent) -import Nostr.Keys (keyPairToPubKeyXO) +import Nostr.InboxModel import Nostr.Publisher -import Nostr.RelayPool -import Nostr.Types hiding (displayName, picture) import Nostr.Util -import Types (AppState(..), RelayPoolState(..), initialRelayPoolState) +import Types (AppState(..), RelayPool(..), initialRelayPool) -- | Key Management UI Effect. -type KeyMgmgtUIEff es = (State AppState :> es, State RelayPoolState :> es, Util :> es, Nostr :> es, Publisher :> es, KeyMgmt :> es, RelayPool :> es, Concurrent :> es, State KeyMgmtState :> es, IOE :> es, QtQuick :> es, FileSystem :> es, Logging :> es) +type KeyMgmgtUIEff es = + ( State AppState :> es + , State RelayPool :> es + , Util :> es + , Nostr :> es + , InboxModel :> es + , Publisher :> es + , KeyMgmt :> es + , Concurrent :> es + , State KeyMgmtState :> es + , IOE :> es + , QtQuick :> es + , FileSystem :> es + , Logging :> es ) -- | Key Management Effect for creating QML UI. data KeyMgmtUI :: Effect where @@ -113,44 +120,9 @@ runKeyMgmtUI action = interpret handleKeyMgmtUI action mkp <- generateSeedphrase obj case mkp of Just kp -> do - let pk = keyPairToPubKeyXO kp modify @AppState $ \s -> s { keyPair = Just kp } - modify @RelayPoolState $ const initialRelayPoolState - now <- getCurrentTime - - -- Import selected general relays - let (rs, _) = defaultGeneralRelays - allRelays <- liftIO $ shuffleM rs - let selectedRelays = take 3 allRelays - importGeneralRelays pk selectedRelays now - - -- Import DM relays first - let (dmRelays', _) = defaultDMRelays - importDMRelays pk dmRelays' now - - -- Connect to all relays at once - let allRelaysToConnect = selectedRelays ++ dmRelays' - forM_ allRelaysToConnect $ \relay -> void $ async $ connect $ getUri relay - - -- Wait for connection and publish events - void $ async $ do - atLeastOneConnected <- awaitAtLeastOneConnected - when atLeastOneConnected $ do - threadDelay 100000 -- wait another 100ms for other relays to connect - -- Broadcast relay list metadata - let unsigned = createRelayListMetadataEvent selectedRelays pk now - signed <- signEvent unsigned kp - case signed of - Just signed' -> broadcast signed' - Nothing -> logError "Failed to sign relay list metadata event" - - -- Broadcast preferred DM relays event - let unsigned' = createPreferredDMRelaysEvent (map getUri dmRelays') pk now - signed' <- signEvent unsigned' kp - case signed' of - Just signed'' -> broadcast signed'' - Nothing -> logError "Failed to sign preferred DM relays event" - + modify @RelayPool $ const initialRelayPool + startInboxModel return True Nothing -> do @@ -160,17 +132,3 @@ runKeyMgmtUI action = interpret handleKeyMgmtUI action ] newObject contextClass () - --- | Check if a relay is inbox capable --- @todo remove duplicated function -isInboxCapable :: Relay -> Bool -isInboxCapable (InboxRelay _) = True -isInboxCapable (InboxOutboxRelay _) = True -isInboxCapable _ = False - - --- | Check if a relay is outbox capable -isOutboxCapable :: Relay -> Bool -isOutboxCapable (OutboxRelay _) = True -isOutboxCapable (InboxOutboxRelay _) = True -isOutboxCapable _ = False diff --git a/src/Presentation/RelayMgmtUI.hs b/src/Presentation/RelayMgmtUI.hs index 1243797..44808bb 100644 --- a/src/Presentation/RelayMgmtUI.hs +++ b/src/Presentation/RelayMgmtUI.hs @@ -6,12 +6,10 @@ module Presentation.RelayMgmtUI where -import Control.Monad (void) import Data.Map.Strict qualified as Map import Data.Text (Text) import Effectful import Effectful.Concurrent -import Effectful.Concurrent.Async (async) import Effectful.Dispatch.Dynamic (EffectHandler, interpret) import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH @@ -20,10 +18,11 @@ import Graphics.QML hiding (fireSignal, runEngineLoop) import QtQuick (QtQuickState(..), UIReferences(..)) import Logging import Nostr.Keys (keyPairToPubKeyXO) -import Nostr.RelayPool import Nostr.Types hiding (displayName, filter, picture) import Nostr.Util -import Types (AppState(..), ConnectionState(..), RelayData(..), RelayPoolState(..)) +import RelayMgmt (RelayMgmt, addDMRelay, addGeneralRelay, removeDMRelay, removeGeneralRelay) +import Store.Lmdb (LmdbStore, getDMRelays, getGeneralRelays) +import Types (AppState(..), ConnectionState(..), RelayData(..), RelayPool(..)) data RelayType = DMRelays | InboxRelays | OutboxRelays @@ -31,9 +30,10 @@ data RelayType = DMRelays | InboxRelays | OutboxRelays -- | Relay Management UI Effect. type RelayMgmgtUIEff es = ( State AppState :> es - , State RelayPoolState :> es + , State RelayPool :> es , State QtQuickState :> es - , RelayPool :> es + , RelayMgmt :> es + , LmdbStore :> es , Logging :> es , Concurrent :> es , Util :> es @@ -64,19 +64,19 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action defPropertySigRO' "connectionState" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - pst <- get @RelayPoolState + pst <- get @RelayPool return $ getConnectionStateText uri' pst, defPropertySigRO' "connectionRetries" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - pst <- get @RelayPoolState + pst <- get @RelayPool return $ case Map.lookup uri' (activeConnections pst) of Just rd -> connectionAttempts rd Nothing -> 0, defPropertySigRO' "notices" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - pst <- get @RelayPoolState + pst <- get @RelayPool return $ case Map.lookup uri' (activeConnections pst) of Just rd -> notices rd Nothing -> [] @@ -87,35 +87,43 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action defPropertySigRO' "connectionState" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - pst <- get @RelayPoolState + pst <- get @RelayPool return $ getConnectionStateText uri' pst, defPropertySigRO' "isInbox" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - outboxState <- get @RelayPoolState - -- DM relays are always readable/writable - let isInDMRelays = any (elem uri' . map getUri . fst) (Map.elems $ dmRelays outboxState) - -- For general relays, check inbox capability - let isInGeneralRelays = any (any (\r -> isInboxCapable r && getUri r == uri') . fst) (Map.elems $ generalRelays outboxState) + kp <- getKeyPair + + dmRelays <- getDMRelays (keyPairToPubKeyXO kp) + let isInDMRelays = uri' `elem` dmRelays + + generalRelays <- getGeneralRelays (keyPairToPubKeyXO kp) + let isInGeneralRelays = any (\r -> isInboxCapable r && getUri r == uri') generalRelays + return $ isInDMRelays || isInGeneralRelays, defPropertySigRO' "isOutbox" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - outboxState <- get @RelayPoolState - let isInDMRelays = any (elem uri' . map getUri . fst) (Map.elems $ dmRelays outboxState) - let isInGeneralRelays = any (any (\r -> isOutboxCapable r && getUri r == uri') . fst) (Map.elems $ generalRelays outboxState) + kp <- getKeyPair + + dmRelays <- getDMRelays (keyPairToPubKeyXO kp) + let isInDMRelays = uri' `elem` dmRelays + + generalRelays <- getGeneralRelays (keyPairToPubKeyXO kp) + let isInGeneralRelays = any (\r -> isOutboxCapable r && getUri r == uri') generalRelays + return $ isInDMRelays || isInGeneralRelays, defPropertySigRO' "connectionRetries" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - pst <- get @RelayPoolState + pst <- get @RelayPool return $ case Map.lookup uri' (activeConnections pst) of Just rd -> connectionAttempts rd Nothing -> 0, defPropertySigRO' "notices" changeKey $ \obj -> runE $ do let uri' = fromObjRef obj - pst <- get @RelayPoolState + pst <- get @RelayPool return $ case Map.lookup uri' (activeConnections pst) of Just rd -> notices rd Nothing -> [] @@ -135,8 +143,8 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action Nothing -> return [] Just kp -> do let pk = keyPairToPubKeyXO kp - (relaysWithStatus, _) <- runE $ getDMRelays pk - mapM (\(relay, _status) -> getPoolObject dmRelayPool (getUri relay)) relaysWithStatus, + relays <- runE $ getDMRelays pk + mapM (\relay -> getPoolObject dmRelayPool relay) relays, defPropertySigRO' "generalRelays" changeKey $ \obj -> do runE $ modify @QtQuickState $ \s -> s { @@ -147,17 +155,14 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action Nothing -> return [] Just kp -> do let pk = keyPairToPubKeyXO kp - outboxState <- runE $ get @RelayPoolState - let rs = case Map.lookup pk (generalRelays outboxState) of - Nothing -> [] - Just (rs', _) -> map getUri rs' - mapM (getPoolObject generalRelayPool) rs, + relays <- runE $ getGeneralRelays pk + mapM (getPoolObject generalRelayPool . getUri) relays, defPropertySigRO' "tempRelays" changeKey $ \obj -> do runE $ modify @QtQuickState $ \s -> s { uiRefs = (uiRefs s) { tempRelaysObjRef = Just obj } } - poolState <- runE $ get @RelayPoolState + poolState <- runE $ get @RelayPool appState <- runE $ get @AppState let activeURIs = Map.keys (activeConnections poolState) @@ -166,13 +171,11 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action Nothing -> return [] Just kp -> do let pk = keyPairToPubKeyXO kp - (dmRelaysWithStatus, _) <- runE $ getDMRelays pk - let dmURIs = map (getUri . fst) dmRelaysWithStatus - let generalURIs = case Map.lookup pk (generalRelays poolState) of - Nothing -> [] - Just (rs, _) -> map getUri rs + dmRelays <- runE $ getDMRelays pk + generalRelays <- runE $ getGeneralRelays pk + let generalURIs = map getUri generalRelays - let tempURIs = filter (\uri -> uri `notElem` dmURIs && uri `notElem` generalURIs) activeURIs + let tempURIs = filter (\uri -> uri `notElem` dmRelays && uri `notElem` generalURIs) activeURIs mapM (getPoolObject tempRelayPool) tempURIs, defMethod' "addDMRelay" $ \_ input -> runE $ do @@ -189,33 +192,14 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action defMethod' "removeGeneralRelay" $ \_ input -> runE $ do kp <- getKeyPair - removeGeneralRelay (keyPairToPubKeyXO kp) input, - - defMethod' "connectRelay" $ \_ input -> runE $ void $ async $ connect input, - - defMethod' "disconnectRelay" $ \_ input -> runE $ disconnect input + removeGeneralRelay (keyPairToPubKeyXO kp) input ] newObject contextClass () --- | Check if a relay is outbox capable --- @todo remove duplicated function -isOutboxCapable :: Relay -> Bool -isOutboxCapable (OutboxRelay _) = True -isOutboxCapable (InboxOutboxRelay _) = True -isOutboxCapable _ = False - - --- | Check if a relay is inbox capable --- @todo remove duplicated function -isInboxCapable :: Relay -> Bool -isInboxCapable (InboxRelay _) = True -isInboxCapable (InboxOutboxRelay _) = True -isInboxCapable _ = False - -- | Helper function to get connection state text -getConnectionStateText :: RelayURI -> RelayPoolState -> Text +getConnectionStateText :: RelayURI -> RelayPool -> Text getConnectionStateText uri pst = case Map.lookup uri (activeConnections pst) of Just rd -> case connectionState rd of Connected -> "Connected" diff --git a/src/QtQuick.hs b/src/QtQuick.hs index edf1e5f..833ddb6 100644 --- a/src/QtQuick.hs +++ b/src/QtQuick.hs @@ -44,6 +44,7 @@ data UIReferences = UIReferences data UIUpdates = UIUpdates { profilesChanged :: Bool , followsChanged :: Bool + , myFollowsChanged :: Bool , postsChanged :: Bool , privateMessagesChanged :: Bool , dmRelaysChanged :: Bool @@ -58,6 +59,7 @@ instance Semigroup UIUpdates where a <> b = UIUpdates { profilesChanged = profilesChanged a || profilesChanged b , followsChanged = followsChanged a || followsChanged b + , myFollowsChanged = myFollowsChanged a || myFollowsChanged b , postsChanged = postsChanged a || postsChanged b , privateMessagesChanged = privateMessagesChanged a || privateMessagesChanged b , dmRelaysChanged = dmRelaysChanged a || dmRelaysChanged b @@ -74,7 +76,7 @@ instance Monoid UIUpdates where -- | Empty UI updates. emptyUpdates :: UIUpdates -emptyUpdates = UIUpdates False False False False False False False False False +emptyUpdates = UIUpdates False False False False False False False False False False -- | Initial effectful QML state. @@ -119,7 +121,8 @@ runQtQuick = interpret $ \_ -> \case refs <- gets uiRefs -- Define update checks and their corresponding refs let updates = [ (profilesChanged, profileObjRef) - , (followsChanged, followsObjRef) + -- followsChanged is not used + , (myFollowsChanged, followsObjRef) , (postsChanged, postsObjRef) , (privateMessagesChanged, privateMessagesObjRef) , (dmRelaysChanged, dmRelaysObjRef) diff --git a/src/RelayMgmt.hs b/src/RelayMgmt.hs index 6af8b77..3c2951d 100644 --- a/src/RelayMgmt.hs +++ b/src/RelayMgmt.hs @@ -2,40 +2,32 @@ module RelayMgmt where -import Control.Monad (forM) -import Data.Map.Strict qualified as Map -import Data.Text (pack) import Effectful import Effectful.Dispatch.Dynamic (interpret) -import Effectful.State.Static.Shared (State, get, gets, modify) import Effectful.TH import QtQuick -import KeyMgmt (AccountId(..), KeyMgmt, updateRelays) import Logging import Nostr -import Nostr.Bech32 (pubKeyXOToBech32) import Nostr.Event (createPreferredDMRelaysEvent, createRelayListMetadataEvent) import Nostr.Keys (PubKeyXO) import Nostr.Publisher import Nostr.RelayConnection -import Nostr.Types (Relay(..), RelayURI, getUri) +import Nostr.Types (Relay(..), RelayURI, defaultDMRelays, defaultGeneralRelays, getUri) import Nostr.Util -import Types (ConnectionState(..), RelayPoolState(..), RelayData(..)) +import Store.Lmdb (LmdbStore, getDMRelays, getGeneralRelays) -- | Effect for handling RelayMgmt operations. data RelayMgmt :: Effect where -- General Relay Management - ImportGeneralRelays :: PubKeyXO -> [Relay] -> Int -> RelayMgmt m () AddGeneralRelay :: PubKeyXO -> RelayURI -> Bool -> Bool -> RelayMgmt m Bool RemoveGeneralRelay :: PubKeyXO -> RelayURI -> RelayMgmt m () - GetGeneralRelays :: PubKeyXO -> RelayMgmt m ([(Relay, ConnectionState)], Int) + SetDefaultGeneralRelays :: PubKeyXO -> RelayMgmt m () -- DM Relay Management - ImportDMRelays :: PubKeyXO -> [Relay] -> Int -> RelayMgmt m () AddDMRelay :: PubKeyXO -> RelayURI -> RelayMgmt m Bool RemoveDMRelay :: PubKeyXO -> RelayURI -> RelayMgmt m () - GetDMRelays :: PubKeyXO -> RelayMgmt m ([(Relay, ConnectionState)], Int) + SetDefaultDMRelays :: PubKeyXO -> RelayMgmt m () type instance DispatchOf RelayMgmt = Dynamic @@ -44,14 +36,13 @@ makeEffect ''RelayMgmt -- | RelayMgmtEff type RelayMgmtEff es = - ( State RelayPoolState :> es - , Nostr :> es + ( Nostr :> es , RelayConnection :> es , Publisher :> es - , KeyMgmt :> es , Logging :> es , QtQuick :> es , Util :> es + , LmdbStore :> es ) @@ -61,18 +52,6 @@ runRelayMgmt => Eff (RelayMgmt : es) a -> Eff es a runRelayMgmt = interpret $ \_ -> \case - ImportGeneralRelays pk rs ts -> do - logDebug $ "Importing general relays for " <> pubKeyXOToBech32 pk <> " with " <> pack (show rs) - let rs' = map normalizeRelay rs - modify @RelayPoolState $ \st -> do - case Map.lookup pk (generalRelays st) of - Nothing -> st { generalRelays = Map.insert pk (rs', ts) (generalRelays st) } - Just (_, existingTs) -> - if ts > existingTs - then st { generalRelays = Map.insert pk (rs', ts) (generalRelays st) } - else st - notifyRelayStatus - AddGeneralRelay pk relay' r w -> do if not r && not w then @@ -83,109 +62,93 @@ runRelayMgmt = interpret $ \_ -> \case (True, False) -> InboxRelay $ normalizeRelayURI relay' (False, True) -> OutboxRelay $ normalizeRelayURI relay' (False, False) -> error "Unreachable due to guard above" - kp <- getKeyPair - st' <- get @RelayPoolState - let (existingRelays, _) = Map.findWithDefault ([], 0) pk (generalRelays st') + + existingRelays <- getGeneralRelays pk if relay'' `elem` existingRelays then return False else do let rs = relay'' : existingRelays now <- getCurrentTime - modify @RelayPoolState $ \st'' -> st'' - { generalRelays = Map.insert pk (rs, now) (generalRelays st'') } - updateRelays (AccountId $ pubKeyXOToBech32 pk) (rs, now) - notifyRelayStatus + kp <- getKeyPair let unsigned = createRelayListMetadataEvent rs pk now signed <- signEvent unsigned kp case signed of Just signed' -> broadcast signed' Nothing -> logError $ "Failed to sign relay list metadata event" + notifyRelayStatus return True RemoveGeneralRelay pk r -> do let r' = normalizeRelayURI r - disconnectRelay r' - modify $ \st -> st - { generalRelays = Map.adjust (removeRelayFromList r') pk (generalRelays st) } - updatedRelays <- gets (Map.findWithDefault ([], 0) pk . generalRelays) - updateRelays (AccountId $ pubKeyXOToBech32 pk) updatedRelays - notifyRelayStatus + disconnect r' + existingRelays <- getGeneralRelays pk + let rs = filter (\relay -> getUri relay /= r') existingRelays + kp <- getKeyPair - st <- get @RelayPoolState - let (rs, _) = Map.findWithDefault ([], 0) pk (generalRelays st) now <- getCurrentTime let unsigned = createRelayListMetadataEvent rs pk now signed <- signEvent unsigned kp case signed of Just signed' -> broadcast signed' Nothing -> logError $ "Failed to sign relay list metadata event" - - GetGeneralRelays pk -> do - st <- get @RelayPoolState - let (relays, timestamp) = Map.findWithDefault ([], 0) pk (generalRelays st) - relaysWithStatus <- forM relays $ \relay -> do - let uri = getUri relay - let status = case Map.lookup uri (activeConnections st) of - Just rd -> connectionState rd - Nothing -> Disconnected - return (relay, status) - return (relaysWithStatus, timestamp) - - ImportDMRelays pk rs ts -> do - let rs' = map normalizeRelay rs - modify @RelayPoolState $ \st -> do - case Map.lookup pk (dmRelays st) of - Nothing -> st { dmRelays = Map.insert pk (rs', ts) (dmRelays st) } - Just (_, existingTs) -> - if ts > existingTs - then st { dmRelays = Map.insert pk (rs', ts) (dmRelays st) } - else st notifyRelayStatus AddDMRelay pk r -> do - st <- get @RelayPoolState - let (existingRelays, _) = Map.findWithDefault ([], 0) pk (dmRelays st) - let newRelay = InboxOutboxRelay $ normalizeRelayURI r + let newRelay = normalizeRelayURI r + existingRelays <- getDMRelays pk if newRelay `elem` existingRelays then return False else do now <- getCurrentTime - modify @RelayPoolState $ \st' -> st' - { dmRelays = Map.insert pk (newRelay : existingRelays, now) (dmRelays st') } - notifyRelayStatus kp <- getKeyPair - let unsigned = createPreferredDMRelaysEvent (map getUri $ newRelay : existingRelays) pk now + let unsigned = createPreferredDMRelaysEvent (newRelay : existingRelays) pk now signed <- signEvent unsigned kp case signed of Just signed' -> broadcast signed' Nothing -> logError $ "Failed to sign preferred DM relays event" + notifyRelayStatus return True RemoveDMRelay pk r -> do let r' = normalizeRelayURI r - modify @RelayPoolState $ \st -> st - { dmRelays = Map.adjust (removeRelayFromList r') pk (dmRelays st) } - notifyRelayStatus + existingRelays <- getDMRelays pk + let rs = filter (\relay -> relay /= r') existingRelays kp <- getKeyPair - st <- get @RelayPoolState - let (rs, _) = Map.findWithDefault ([], 0) pk (dmRelays st) now <- getCurrentTime - let unsigned = createPreferredDMRelaysEvent (map getUri rs) pk now + let unsigned = createPreferredDMRelaysEvent rs pk now signed <- signEvent unsigned kp case signed of Just signed' -> broadcast signed' Nothing -> logError $ "Failed to sign preferred DM relays event" + notifyRelayStatus - GetDMRelays pk -> do - st <- get @RelayPoolState - let (relays, timestamp) = Map.findWithDefault ([], 0) pk (dmRelays st) - relaysWithStatus <- forM relays $ \relay -> do - let uri = getUri relay - let status = case Map.lookup uri (activeConnections st) of - Just rd -> connectionState rd - Nothing -> Disconnected - return (relay, status) - return (relaysWithStatus, timestamp) + SetDefaultGeneralRelays xo -> do + logInfo "Setting default general relays..." + kp <- getKeyPair + now <- getCurrentTime + let (relays, _) = defaultGeneralRelays + unsigned = createRelayListMetadataEvent relays xo now + signed <- signEvent unsigned kp + case signed of + Just event -> do + broadcast event + logInfo "Successfully set default general relays" + Nothing -> + logError "Failed to sign relay list metadata event" + + SetDefaultDMRelays xo -> do + logInfo "Setting default DM relays..." + kp <- getKeyPair + now <- getCurrentTime + let (dmRelays, _) = defaultDMRelays + unsigned = createPreferredDMRelaysEvent dmRelays xo now + signed <- signEvent unsigned kp + case signed of + Just event -> do + broadcast event + logInfo "Successfully set default DM relays" + Nothing -> + logError "Failed to sign preferred DM relays event" -- | Normalize a Relay by normalizing its URI @@ -194,9 +157,3 @@ normalizeRelay relay = case relay of InboxRelay uri -> InboxRelay (normalizeRelayURI uri) OutboxRelay uri -> OutboxRelay (normalizeRelayURI uri) InboxOutboxRelay uri -> InboxOutboxRelay (normalizeRelayURI uri) - - --- | Remove a specific relay from a relay list without affecting other relays -removeRelayFromList :: RelayURI -> ([Relay], Int) -> ([Relay], Int) -removeRelayFromList uri (relays, timestamp) = - (filter (\relay -> getUri relay /= uri) relays, timestamp) diff --git a/src/Store/Lmdb.hs b/src/Store/Lmdb.hs index 361ebe8..b0acc04 100644 --- a/src/Store/Lmdb.hs +++ b/src/Store/Lmdb.hs @@ -20,35 +20,40 @@ module Store.Lmdb , getFollows , getProfile , getTimelineIds - , isEmpty + , getGeneralRelays + , getDMRelays + , getLatestTimestamp ) where import Control.Concurrent.MVar (MVar, newMVar, withMVar) -import Control.Monad (forM_) +import Control.Monad (forM, forM_, when) import Data.Aeson (ToJSON, FromJSON, encode, decode, eitherDecode) import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Cache.LRU qualified as LRU import Data.List (sort) -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes, mapMaybe) import Data.Set qualified as Set +import Data.Text (unpack) import Data.Text.Encoding (encodeUtf8) import Effectful import Effectful.Dispatch.Dynamic -import Effectful.State.Static.Shared (State, get, modify, put) +import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH (makeEffect) +import GHC.Generics (Generic) import Lmdb.Codec qualified as Codec import Lmdb.Connection import Lmdb.Map qualified as Map import Lmdb.Types +import Network.URI (URI(..), parseURI, uriAuthority, uriRegName, uriScheme) import Pipes.Prelude qualified as Pipes import Pipes ((>->)) -import GHC.Generics (Generic) -import qualified Data.Cache.LRU as LRU import Logging import Nostr.Event (validateEvent, unwrapGiftWrap, unwrapSeal) import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) -import Nostr.Types ( Event(..), EventId(..), Kind(..), Profile, Tag(..) - , Rumor(..), rumorPubKey, rumorTags, rumorCreatedAt, emptyProfile ) +import Nostr.Types ( Event(..), EventId(..), Kind(..), Profile, Relay, RelayURI, Tag(..) + , Rumor(..), emptyProfile, getUri, isValidRelayURI + , rumorPubKey, rumorTags, rumorCreatedAt ) import Nostr.Util import Types (EventWithRelays(..), Follow(..)) @@ -69,24 +74,32 @@ data LmdbState = LmdbState , postTimelineDb :: Database (PubKeyXO, Int) EventId , chatTimelineDb :: Database (PubKeyXO, Int) EventId , followsDb :: Database PubKeyXO [Follow] + , generalRelaysDb :: Database PubKeyXO ([Relay], Int) + , dmRelaysDb :: Database PubKeyXO ([RelayURI], Int) + , latestTimestampDb :: Database (PubKeyXO, Kind) Int , eventCache :: LRU.LRU EventId EventWithRelays , profileCache :: LRU.LRU PubKeyXO (Profile, Int) , followsCache :: LRU.LRU PubKeyXO [Follow] , timelineCache :: LRU.LRU (TimelineType, PubKeyXO, Int) [EventId] + , generalRelaysCache :: LRU.LRU PubKeyXO ([Relay], Int) + , dmRelaysCache :: LRU.LRU PubKeyXO ([RelayURI], Int) + , latestTimestampCache :: LRU.LRU (PubKeyXO, Kind) Int } deriving (Generic) -- | LmdbStore operations data LmdbStore :: Effect where -- Event operations - PutEvent :: EventWithRelays -> LmdbStore m () + PutEvent :: EventWithRelays -> LmdbStore m Bool -- Query operations (read-only) GetEvent :: EventId -> LmdbStore m (Maybe EventWithRelays) GetFollows :: PubKeyXO -> LmdbStore m [Follow] - GetProfile :: PubKeyXO -> LmdbStore m (Profile, Int) + GetProfile :: PubKeyXO -> LmdbStore m Profile GetTimelineIds :: TimelineType -> PubKeyXO -> Int -> LmdbStore m [EventId] - IsEmpty :: LmdbStore m Bool + GetGeneralRelays :: PubKeyXO -> LmdbStore m [Relay] + GetDMRelays :: PubKeyXO -> LmdbStore m [RelayURI] + GetLatestTimestamp :: PubKeyXO -> [Kind] -> LmdbStore m (Maybe Int) type instance DispatchOf LmdbStore = Dynamic @@ -100,12 +113,24 @@ runLmdbStore :: (Util :> es, IOE :> es, State LmdbState :> es, Logging :> es) -> Eff es a runLmdbStore = interpret $ \_ -> \case PutEvent ev -> do + let author = pubKey $ event ev + eventKind = kind $ event ev + eventTimestamp = createdAt $ event ev + currentState <- get @LmdbState kp <- getKeyPair - liftIO $ withMVar (lmdbLock currentState) $ \_ -> withTransaction (lmdbEnv currentState) $ \txn -> do + wasUpdated <- liftIO $ withMVar (lmdbLock currentState) $ \_ -> withTransaction (lmdbEnv currentState) $ \txn -> do Map.repsert' txn (eventDb currentState) (eventId $ event ev) ev - case kind (event ev) of + existingTimestamp <- Map.lookup' (readonly txn) (latestTimestampDb currentState) (author, eventKind) + case existingTimestamp of + Just existingTs -> + when (eventTimestamp > existingTs) $ + Map.repsert' txn (latestTimestampDb currentState) (author, eventKind) eventTimestamp + Nothing -> + Map.repsert' txn (latestTimestampDb currentState) (author, eventKind) eventTimestamp + + case eventKind of GiftWrap -> do mSealedEvent <- unwrapGiftWrap (event ev) kp case mSealedEvent of @@ -121,69 +146,156 @@ runLmdbStore = interpret $ \_ -> \case else filter (/= keyPairToPubKeyXO kp) (rumorPubKey decryptedRumor : sort (getAllPTags (rumorTags decryptedRumor))) addTimelineEntryTx txn (chatTimelineDb currentState) ev participants (rumorCreatedAt decryptedRumor) - _ -> pure () - _ -> pure () - _ -> pure () + pure True + _ -> pure False + _ -> pure False + _ -> pure False - ShortTextNote -> - addTimelineEntryTx txn (postTimelineDb currentState) ev [pubKey $ event ev] (createdAt $ event ev) + ShortTextNote -> do + addTimelineEntryTx txn (postTimelineDb currentState) ev [author] eventTimestamp + pure True Repost -> do let etags = [t | t@(ETag _ _ _) <- tags (event ev)] - let mOriginalEvent = eitherDecode (fromStrict $ encodeUtf8 $ content $ event ev) + mOriginalEvent = eitherDecode (fromStrict $ encodeUtf8 $ content $ event ev) case (etags, mOriginalEvent) of (ETag _ _ _ : _, Right originalEvent) | validateEvent originalEvent -> do Map.repsert' txn (eventDb currentState) (eventId originalEvent) (EventWithRelays originalEvent Set.empty) - addTimelineEntryTx txn (postTimelineDb currentState) ev [pubKey $ event ev] - (createdAt $ event ev) - _ -> pure () + addTimelineEntryTx txn (postTimelineDb currentState) ev [author] eventTimestamp + pure True + _ -> pure False EventDeletion -> do let eventIdsToDelete = [eid | ETag eid _ _ <- tags (event ev)] - forM_ eventIdsToDelete $ \eid -> do + res <- forM eventIdsToDelete $ \eid -> do mEvent <- Map.lookup' (readonly txn) (eventDb currentState) eid case mEvent of Just deletedEv -> do let key = (pubKey $ event deletedEv, createdAt $ event deletedEv) - db = case kind (event deletedEv) of - ShortTextNote -> (postTimelineDb currentState) - Repost -> (postTimelineDb currentState) - _ -> (chatTimelineDb currentState) - Map.delete' txn db key - Map.delete' txn (eventDb currentState) eid - Nothing -> pure () - - Metadata -> + timelineDb = case kind (event deletedEv) of + ShortTextNote -> Just $ postTimelineDb currentState + Repost -> Just $ postTimelineDb currentState + GiftWrap -> Just $ chatTimelineDb currentState + _ -> Nothing + + result <- case timelineDb of + Just db -> do + Map.delete' txn db key + Map.delete' txn (eventDb currentState) eid + pure True + Nothing -> pure False + + pure result + + Nothing -> pure False + + pure $ any id res + + Metadata -> do case eitherDecode (fromStrict $ encodeUtf8 $ content $ event ev) of - Right profile -> - Map.repsert' txn (profileDb currentState) (pubKey $ event ev) (profile, createdAt $ event ev) - Left _ -> pure () + Right profile -> do + Map.repsert' txn (profileDb currentState) author (profile, eventTimestamp) + pure True + Left _ -> pure False FollowList -> do let followList' = [Follow pk petName' | PTag pk _ petName' <- tags (event ev)] - authorPk = pubKey $ event ev - Map.repsert' txn (followsDb currentState) authorPk followList' - - _ -> pure () - - let newEventCache = LRU.insert (eventId $ event ev) ev (eventCache currentState) - newProfileCache = case kind (event ev) of - Metadata -> case eitherDecode (fromStrict $ encodeUtf8 $ content (event ev)) of - Right profile -> LRU.insert (pubKey $ event ev) (profile, createdAt $ event ev) (profileCache currentState) - Left _ -> profileCache currentState - _ -> profileCache currentState - newFollowsCache = case kind (event ev) of - FollowList -> let followList' = [Follow pk petName' | PTag pk _ petName' <- tags (event ev)] - in LRU.insert (pubKey $ event ev) followList' (followsCache currentState) - _ -> followsCache currentState - - put @LmdbState currentState - { eventCache = newEventCache - , profileCache = newProfileCache - , followsCache = newFollowsCache - } + existingTimestamp <- Map.lookup' (readonly txn) (latestTimestampDb currentState) (author, eventKind) + case existingTimestamp of + Just existingTs -> + if eventTimestamp > existingTs then do + Map.repsert' txn (followsDb currentState) author followList' + pure True + else pure False + Nothing -> do + Map.repsert' txn (followsDb currentState) author followList' + pure True + + PreferredDMRelays -> do + let validRelayTags = [ r' | RelayTag r' <- tags (event ev), isValidRelayURI r' ] + case validRelayTags of + [] -> pure False + relays -> do + existingRelays <- Map.lookup' (readonly txn) (dmRelaysDb currentState) author + case existingRelays of + Just (_, existingTs) -> + if eventTimestamp > existingTs then do + Map.repsert' txn (dmRelaysDb currentState) author (relays, eventTimestamp) + pure True + else pure False + Nothing -> do + Map.repsert' txn (dmRelaysDb currentState) author (relays, eventTimestamp) + pure True + + RelayListMetadata -> do + let validRelayTags = [ r' | RTag r' <- tags (event ev), isValidRelayURI (getUri r') ] + case validRelayTags of + [] -> pure False + relays -> do + existingRelays <- Map.lookup' (readonly txn) (generalRelaysDb currentState) author + case existingRelays of + Just (_, existingTs) -> + if eventTimestamp > existingTs then do + Map.repsert' txn (generalRelaysDb currentState) author (relays, eventTimestamp) + pure True + else pure False + Nothing -> do + Map.repsert' txn (generalRelaysDb currentState) author (relays, eventTimestamp) + pure True + + _ -> pure False + + -- Update caches + modify @LmdbState $ \s -> s { eventCache = LRU.insert (eventId $ event ev) ev (eventCache s) } + + case eventKind of + Metadata -> + case eitherDecode (fromStrict $ encodeUtf8 $ content (event ev)) of + Right profile -> + modify @LmdbState $ \s -> s + { profileCache = LRU.insert author (profile, eventTimestamp) (profileCache s) } + Left _ -> + pure () + + EventDeletion -> + let eventIdsToDelete = [eid | ETag eid _ _ <- tags (event ev)] + in modify @LmdbState $ \s -> s + { eventCache = foldr (\eid cache -> fst $ LRU.delete eid cache) (eventCache s) eventIdsToDelete + , timelineCache = foldr (\eid cache -> + case LRU.lookup eid (eventCache s) of + (_, Just ev') -> + let timelineType = if kind (event ev') `elem` [ShortTextNote, Repost] + then PostTimeline + else ChatTimeline + key = (timelineType, pubKey $ event ev', createdAt $ event ev') + in fst $ LRU.delete key cache + (_, Nothing) -> cache + ) (timelineCache s) eventIdsToDelete + } + + FollowList -> + when wasUpdated $ + let followList' = [Follow pk petName' | PTag pk _ petName' <- tags (event ev)] + in modify @LmdbState $ \s -> s + { followsCache = LRU.insert author followList' (followsCache s) } + + PreferredDMRelays -> + when wasUpdated $ + let validRelays = [ r' | RelayTag r' <- tags (event ev), isValidRelayURI r' ] + in modify @LmdbState $ \s -> s + { dmRelaysCache = LRU.insert author (validRelays, eventTimestamp) (dmRelaysCache s) } + + RelayListMetadata -> + when wasUpdated $ + let validRelays = [ r' | RTag r' <- tags (event ev), isValidRelayURI (getUri r') ] + in modify @LmdbState $ \s -> s + { generalRelaysCache = LRU.insert author (validRelays, eventTimestamp) (generalRelaysCache s) } + + _ -> pure () + + pure wasUpdated -- Query operations (read-only) @@ -211,22 +323,24 @@ runLmdbStore = interpret $ \_ -> \case (_, Nothing) -> do mfs <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> do Map.lookup' (readonly txn) (followsDb st) pk - let fs = maybe [] id mfs - modify @LmdbState $ \s -> s { followsCache = LRU.insert pk fs $ followsCache s } - pure fs + case mfs of + Just follows -> do + modify @LmdbState $ \s -> s { followsCache = LRU.insert pk follows $ followsCache s } + pure follows + Nothing -> pure [] GetProfile pk -> do st <- get @LmdbState case LRU.lookup pk (profileCache st) of - (newCache, Just p) -> do + (newCache, Just (profile, _)) -> do modify @LmdbState $ \s -> s { profileCache = newCache } - pure p + pure profile (_, Nothing) -> do mp <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> do Map.lookup' (readonly txn) (profileDb st) pk - let p = maybe (emptyProfile, 0) id mp - modify @LmdbState $ \s -> s { profileCache = LRU.insert pk p $ profileCache s } - pure p + let (profile, _) = maybe (emptyProfile, 0) id mp + modify @LmdbState $ \s -> s { profileCache = LRU.insert pk (profile, 0) $ profileCache s } + pure profile GetTimelineIds timelineType author limit -> do st <- get @LmdbState @@ -246,14 +360,58 @@ runLmdbStore = interpret $ \_ -> \case modify @LmdbState $ \s -> s { timelineCache = LRU.insert cacheKey ids $ timelineCache s } pure ids - IsEmpty -> do + GetGeneralRelays pubKey -> do + st <- get @LmdbState + case LRU.lookup pubKey (generalRelaysCache st) of + (newCache, Just (relays, _)) -> do + modify @LmdbState $ \s -> s { generalRelaysCache = newCache } + pure relays + (_, Nothing) -> do + mRelays <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> + Map.lookup' (readonly txn) (generalRelaysDb st) pubKey + case mRelays of + Just (relaysList, timestamp) -> do + modify @LmdbState $ \s -> s { generalRelaysCache = LRU.insert pubKey (relaysList, timestamp) $ generalRelaysCache s } + pure relaysList + Nothing -> do + pure [] + + GetDMRelays pubKey -> do + st <- get @LmdbState + case LRU.lookup pubKey (dmRelaysCache st) of + (newCache, Just (relays, _)) -> do + modify @LmdbState $ \s -> s { dmRelaysCache = newCache } + pure relays + (_, Nothing) -> do + mRelays <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> + Map.lookup' (readonly txn) (dmRelaysDb st) pubKey + case mRelays of + Just (relaysList, timestamp) -> do + modify @LmdbState $ \s -> s { dmRelaysCache = LRU.insert pubKey (relaysList, timestamp) $ dmRelaysCache s } + pure relaysList + Nothing -> do + pure [] + + GetLatestTimestamp pubKey kinds -> do st <- get @LmdbState - -- Check if the eventDb is empty - empty <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> do - withCursor txn (eventDb st) $ \cursor -> do - entries <- Pipes.toListM (Map.firstForward cursor) -- Get all entries - return (null entries) -- If the list is empty, the db is empty - pure empty + timestamps <- forM kinds $ \k -> do + let key = (pubKey, k) + case LRU.lookup key (latestTimestampCache st) of + (newCache, Just ts) -> do + modify @LmdbState $ \s -> s { latestTimestampCache = newCache } + return (Just ts) + (_, Nothing) -> do + mts <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> + Map.lookup' (readonly txn) (latestTimestampDb st) key + case mts of + Just ts -> do + -- Update the cache + modify @LmdbState $ \s -> s { latestTimestampCache = LRU.insert key ts (latestTimestampCache s) } + return (Just ts) + Nothing -> return Nothing + + let validTimestamps = catMaybes timestamps + return $ if null validTimestamps then Nothing else Just (maximum validTimestamps) -- Helper function for timeline entries within a transaction @@ -304,26 +462,6 @@ initializeEnv dbPath = do lock <- newMVar () pure (env, lock) --- | Initialize the event database -initEventDb :: Transaction 'ReadWrite -> IO (Database EventId EventWithRelays) -initEventDb txn = openDatabase txn (Just "events") eventDbSettings - --- | Initialize the follows database -initFollowsDb :: Transaction 'ReadWrite -> IO (Database PubKeyXO [Follow]) -initFollowsDb txn = openDatabase txn (Just "follows") followsDbSettings - --- | Initialize the profile database -initProfileDb :: Transaction 'ReadWrite -> IO (Database PubKeyXO (Profile, Int)) -initProfileDb txn = openDatabase txn (Just "profiles") defaultJsonSettings - --- | Initialize the post timeline database -initPostTimelineDb :: Transaction 'ReadWrite -> IO (Database TimelineKey EventId) -initPostTimelineDb txn = openDatabase txn (Just "post_timeline") defaultJsonSettings - --- | Initialize the chat timeline database -initChatTimelineDb :: Transaction 'ReadWrite -> IO (Database TimelineKey EventId) -initChatTimelineDb txn = openDatabase txn (Just "chat_timeline") defaultJsonSettings - -- | Settings for the event database eventDbSettings :: DatabaseSettings EventId EventWithRelays eventDbSettings = makeSettings @@ -354,6 +492,22 @@ followsDbSettings = makeSettings Left _ -> Nothing)) +-- | Settings for the latest timestamp database +latestTimestampDbSettings :: DatabaseSettings (PubKeyXO, Kind) Int +latestTimestampDbSettings = makeSettings + (SortCustom $ CustomSortSafe compare) + (Codec.throughByteString + (\(pk, k) -> toStrict $ encode (pk, k)) + (\bs -> case eitherDecode (fromStrict bs) of + Right key -> Just key + Left _ -> Nothing)) + (Codec.throughByteString + (toStrict . encode) + (\bs -> case eitherDecode (fromStrict bs) of + Right ts -> Just ts + Left _ -> Nothing)) + + -- | Get all p tags from the rumor tags getAllPTags :: [Tag] -> [PubKeyXO] getAllPTags = mapMaybe extractPubKey @@ -366,11 +520,15 @@ initializeLmdbState :: FilePath -> IO LmdbState initializeLmdbState dbPath = do (env, lock) <- initializeEnv dbPath withTransaction env $ \txn -> do - eventDb' <- initEventDb txn - followsDb' <- initFollowsDb txn - profileDb' <- initProfileDb txn - postTimelineDb' <- initPostTimelineDb txn - chatTimelineDb' <- initChatTimelineDb txn + eventDb' <- openDatabase txn (Just "events") eventDbSettings + followsDb' <- openDatabase txn (Just "follows") followsDbSettings + profileDb' <- openDatabase txn (Just "profiles") defaultJsonSettings + postTimelineDb' <- openDatabase txn (Just "post_timeline") defaultJsonSettings + chatTimelineDb' <- openDatabase txn (Just "chat_timeline") defaultJsonSettings + generalRelaysDb' <- openDatabase txn (Just "general_relays") defaultJsonSettings + dmRelaysDb' <- openDatabase txn (Just "dm_relays") defaultJsonSettings + latestTimestampDb' <- openDatabase txn (Just "latest_timestamps") latestTimestampDbSettings + pure $ LmdbState { lmdbLock = lock , lmdbEnv = env @@ -379,16 +537,25 @@ initializeLmdbState dbPath = do , postTimelineDb = postTimelineDb' , chatTimelineDb = chatTimelineDb' , followsDb = followsDb' + , generalRelaysDb = generalRelaysDb' + , dmRelaysDb = dmRelaysDb' + , latestTimestampDb = latestTimestampDb' , eventCache = LRU.newLRU (Just cacheSize) - , profileCache = LRU.newLRU (Just cacheSize) - , followsCache = LRU.newLRU (Just cacheSize) + , profileCache = LRU.newLRU (Just smallCacheSize) + , followsCache = LRU.newLRU (Just smallCacheSize) , timelineCache = LRU.newLRU (Just cacheSize) + , generalRelaysCache = LRU.newLRU (Just smallCacheSize) + , dmRelaysCache = LRU.newLRU (Just smallCacheSize) + , latestTimestampCache = LRU.newLRU (Just smallCacheSize) } -- | Cache size constants cacheSize :: Integer cacheSize = 5000 +smallCacheSize :: Integer +smallCacheSize = 500 + -- | Initial LMDB state before login initialLmdbState :: LmdbState initialLmdbState = LmdbState @@ -399,8 +566,14 @@ initialLmdbState = LmdbState , postTimelineDb = error "LMDB not initialized" , chatTimelineDb = error "LMDB not initialized" , followsDb = error "LMDB not initialized" + , generalRelaysDb = error "LMDB not initialized" + , dmRelaysDb = error "LMDB not initialized" + , latestTimestampDb = error "LMDB not initialized" , eventCache = LRU.newLRU (Just cacheSize) - , profileCache = LRU.newLRU (Just cacheSize) - , followsCache = LRU.newLRU (Just cacheSize) + , profileCache = LRU.newLRU (Just smallCacheSize) + , followsCache = LRU.newLRU (Just smallCacheSize) , timelineCache = LRU.newLRU (Just cacheSize) + , generalRelaysCache = LRU.newLRU (Just smallCacheSize) + , dmRelaysCache = LRU.newLRU (Just smallCacheSize) + , latestTimestampCache = LRU.newLRU (Just smallCacheSize) } diff --git a/src/Types.hs b/src/Types.hs index bf9f193..fde25d7 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -9,10 +9,11 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Text (Text) +import Control.Concurrent.Async (Async) import Effectful.Concurrent.STM (TChan, TQueue) import GHC.Generics (Generic) import Nostr.Keys (KeyPair, PubKeyXO) -import Nostr.Types (Event, EventId, Filter, Relay(..), RelayURI, Request, SubscriptionId) +import Nostr.Types (Event, EventId, Filter, RelayURI, Request, SubscriptionId) -- | Status of a publish operation @@ -32,11 +33,14 @@ data SubscriptionEvent -- | State for RelayPool handling. -data RelayPoolState = RelayPoolState +data RelayPool = RelayPool { activeConnections :: Map RelayURI RelayData + , subscriptions :: Map SubscriptionId SubscriptionDetails + , pendingSubscriptions :: Map SubscriptionId SubscriptionDetails , publishStatus :: Map EventId (Map RelayURI PublishStatus) - , generalRelays :: Map PubKeyXO ([Relay], Int) - , dmRelays :: Map PubKeyXO ([Relay], Int) + , inboxQueue :: TQueue (RelayURI, SubscriptionEvent) + , updateQueue :: TQueue () + , updateThread :: Maybe (Async ()) } @@ -44,9 +48,10 @@ data RelayPoolState = RelayPoolState data SubscriptionDetails = SubscriptionDetails { subscriptionId :: SubscriptionId , subscriptionFilter :: Filter - , responseQueue :: TQueue SubscriptionEvent + , responseQueue :: TQueue (RelayURI, SubscriptionEvent) , eventsProcessed :: Int , newestCreatedAt :: Int + , relay :: RelayURI } @@ -71,7 +76,6 @@ data ConnectionState = Connected | Disconnected | Connecting data RelayData = RelayData { connectionState :: ConnectionState , requestChannel :: TChan Request - , activeSubscriptions :: Map SubscriptionId SubscriptionDetails , notices :: [Text] , lastError :: Maybe ConnectionError , connectionAttempts :: Int @@ -82,12 +86,15 @@ data RelayData = RelayData -- | Initial state for RelayPool. -initialRelayPoolState :: RelayPoolState -initialRelayPoolState = RelayPoolState +initialRelayPool :: RelayPool +initialRelayPool = RelayPool { activeConnections = Map.empty + , subscriptions = Map.empty + , pendingSubscriptions = Map.empty , publishStatus = Map.empty - , generalRelays = Map.empty - , dmRelays = Map.empty + , inboxQueue = undefined + , updateQueue = undefined + , updateThread = Nothing } diff --git a/src/UI.hs b/src/UI.hs index c9215e2..17758c3 100644 --- a/src/UI.hs +++ b/src/UI.hs @@ -33,12 +33,6 @@ import Nostr.Bech32 import Nostr.Event (createMetadata) import Nostr.Publisher import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) -import Nostr.Subscription ( subscribeToReactions - , subscribeToReposts - , subscribeToComments - , countEvents - , subscribeToFollowers - , subscribeToFollowing ) import Nostr.Types ( Event(..), EventId(..), Kind(..), Profile(..), RelayURI , Relationship(..), Rumor(..), Tag(..) ) import Nostr.Util @@ -79,37 +73,37 @@ runUI = interpret $ \_ -> \case defPropertySigRO' "name" changeKey' $ \_ -> do st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st - (profile, _) <- runE $ getProfile pk + profile <- runE $ getProfile pk return $ name profile, defPropertySigRO' "displayName" changeKey' $ \_ -> do st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st - (profile, _) <- runE $ getProfile pk + profile <- runE $ getProfile pk return $ displayName profile, defPropertySigRO' "about" changeKey' $ \_ -> do st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st - (profile, _) <- runE $ getProfile pk + profile <- runE $ getProfile pk return $ about profile, defPropertySigRO' "picture" changeKey' $ \_ -> do st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st - (profile, _) <- runE $ getProfile pk + profile <- runE $ getProfile pk return $ picture profile, defPropertySigRO' "nip05" changeKey' $ \_ -> do st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st - (profile, _) <- runE $ getProfile pk + profile <- runE $ getProfile pk return $ nip05 profile, defPropertySigRO' "banner" changeKey' $ \_ -> do st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st - (profile, _) <- runE $ getProfile pk + profile <- runE $ getProfile pk return $ banner profile, defPropertySigRO' "isFollow" changeKey' $ \_ -> do @@ -123,14 +117,20 @@ runUI = interpret $ \_ -> \case _ -> return False, defPropertySigRO' "followerCount" changeKey' $ \obj -> do + return (0 :: Int), + {- st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st runE $ getProfileEventCount subscribeToFollowers pk, + -} defPropertySigRO' "followingCount" changeKey' $ \obj -> do + return (0 :: Int) + {- st <- runE $ get @AppState let pk = fromMaybe (error "No pubkey for current profile") $ currentProfile st runE $ getProfileEventCount subscribeToFollowing pk + -} ] let followProp name' accessor = defPropertySigRO' name' changeKey' $ \obj -> do @@ -151,13 +151,13 @@ runUI = interpret $ \_ -> \case followProp "pubkey" $ \_ -> return . maybe "" (pubKeyXOToBech32 . pubkey), followProp "petname" $ \_ -> return . maybe "" (fromMaybe "" . petName), followProp "displayName" $ \_ -> maybe (return "") (\follow -> do - (profile, _) <- runE $ getProfile (pubkey follow) + profile <- runE $ getProfile (pubkey follow) return $ fromMaybe "" (displayName profile)), followProp "name" $ \_ -> maybe (return "") (\follow -> do - (profile, _) <- runE $ getProfile (pubkey follow) + profile <- runE $ getProfile (pubkey follow) return $ fromMaybe "" (name profile)), followProp "picture" $ \_ -> maybe (return "") (\follow -> do - (profile, _) <- runE $ getProfile (pubkey follow) + profile <- runE $ getProfile (pubkey follow) return $ fromMaybe "" (picture profile)) ] @@ -172,7 +172,7 @@ runUI = interpret $ \_ -> \case case find (\case ETag _ _ (Just Reply) -> True; _ -> False) (tags evt) of Just (ETag eid _ _) -> return $ Just eid _ -> return Nothing - +{- getEventCount subscriber postId = do eventMaybe <- getEvent postId case eventMaybe of @@ -185,7 +185,7 @@ runUI = interpret $ \_ -> \case Just queue -> countEvents queue Nothing -> return 0 Nothing -> return 0 - +-} postClass <- mfix $ \postClass' -> newClass [ defPropertySigRO' "id" changeKey' $ \obj -> do let eid = fromObjRef obj :: EventId @@ -287,22 +287,18 @@ runUI = interpret $ \_ -> \case Nothing -> return [], -- Event count properties using the helper - defPropertySigRO' "reactionCount" changeKey' $ \obj -> - runE $ getEventCount subscribeToReactions (fromObjRef obj), + defPropertySigRO' "repostCount" changeKey' $ \obj -> do + return (0 :: Int), + --runE $ getEventCount subscribeToReposts (fromObjRef obj), - defPropertySigRO' "repostCount" changeKey' $ \obj -> - runE $ getEventCount subscribeToReposts (fromObjRef obj), - - defPropertySigRO' "commentCount" changeKey' $ \obj -> - runE $ getEventCount subscribeToComments (fromObjRef obj) + defPropertySigRO' "commentCount" changeKey' $ \obj -> do + return (0 :: Int) + --runE $ getEventCount subscribeToComments (fromObjRef obj) ] - -- Create the pools postsPool <- newFactoryPool (newObject postClass) chatPool <- newFactoryPool (newObject postClass) - return (postClass, postsPool, chatPool) - rootClass <- newClass [ defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj), @@ -336,8 +332,8 @@ runUI = interpret $ \_ -> \case st <- runE $ get @AppState case keyPair st of Just kp -> do - (profile', _) <- runE $ getProfile $ keyPairToPubKeyXO kp - return $ fromMaybe "" $ picture profile' + profile <- runE $ getProfile $ keyPairToPubKeyXO kp + return $ fromMaybe "" $ picture profile Nothing -> return "", defSignal "loginStatusChanged" (Proxy :: Proxy LoginStatusChanged),