From f4b0362079a2d99a324a8259b77907d72cf222e5 Mon Sep 17 00:00:00 2001 From: prolic Date: Sat, 25 Jan 2025 23:00:34 -0300 Subject: [PATCH] Fixes for Subscripton Handling and Caching - Add PTagList variant for handling multiple pubkeys - Rename Relationship to Marker for clarity - Add pubkey field to ETag for better NIP compliance - Improve tag parsing with better error handling - Fix collectEventsUntilEose to wait for all relay EOSE signals - Remove redundant relay field from follow list comparison - Optimize profile and event caching with invalidation on updates - Fix event deletion by properly clearing caches and databases - Make post and private message views consistent in styling and behavior - Improve timeline cache handling and event updates - Remove redundant event caching in publisher --- resources/qml/content/FollowList.ui.qml | 1 - resources/qml/content/MainContent.ui.qml | 178 +++++++++++----------- src/Futr.hs | 12 +- src/Main.hs | 1 + src/Nostr/Event.hs | 30 ++-- src/Nostr/InboxModel.hs | 88 ++++++----- src/Nostr/Publisher.hs | 16 +- src/Nostr/RelayConnection.hs | 4 +- src/Nostr/Subscription.hs | 48 +----- src/Nostr/Types.hs | 87 +++++++---- src/Store/Lmdb.hs | 182 +++++++++++++---------- src/UI.hs | 13 +- 12 files changed, 336 insertions(+), 324 deletions(-) diff --git a/resources/qml/content/FollowList.ui.qml b/resources/qml/content/FollowList.ui.qml index 4c5fea9..05f9344 100644 --- a/resources/qml/content/FollowList.ui.qml +++ b/resources/qml/content/FollowList.ui.qml @@ -40,7 +40,6 @@ Rectangle { mode: AutoListModel.ByKey equalityTest: function (oldItem, newItem) { return oldItem.pubkey === newItem.pubkey - && oldItem.relay === newItem.relay && oldItem.petname === newItem.petname && oldItem.displayName === newItem.displayName && oldItem.name === newItem.name diff --git a/resources/qml/content/MainContent.ui.qml b/resources/qml/content/MainContent.ui.qml index f1d3e47..51a8f1f 100644 --- a/resources/qml/content/MainContent.ui.qml +++ b/resources/qml/content/MainContent.ui.qml @@ -163,110 +163,101 @@ Rectangle { Layout.topMargin: Constants.spacing_m currentIndex: chatTypeSelector.currentIndex - // Public Notes View - Item { + ColumnLayout { Layout.fillWidth: true Layout.fillHeight: true + spacing: Constants.spacing_m - ColumnLayout { - anchors.fill: parent + // Public notes list + ListView { + id: postsView + Layout.fillWidth: true + Layout.fillHeight: true + clip: true + leftMargin: Constants.spacing_m + rightMargin: Constants.spacing_m spacing: Constants.spacing_m + bottomMargin: 0 - // Public notes list (now takes all space except input area) - ListView { - id: postsView - Layout.fillWidth: true - Layout.fillHeight: true - clip: true - leftMargin: Constants.spacing_m - rightMargin: Constants.spacing_m - spacing: Constants.spacing_m - bottomMargin: Constants.spacing_m - - model: AutoListModel { - id: postsModel - source: posts - mode: AutoListModel.ByKey - equalityTest: function (oldItem, newItem) { - return oldItem.content === newItem.content - && oldItem.timestamp === newItem.timestamp - } + model: AutoListModel { + id: postsModel + source: posts + mode: AutoListModel.ByKey + equalityTest: function (oldItem, newItem) { + return oldItem.id === newItem.id } + } - delegate: Loader { - active: modelData !== undefined && modelData !== null - width: postsView.width - postsView.leftMargin - postsView.rightMargin - height: active ? item.implicitHeight : 0 + delegate: Loader { + active: modelData !== undefined && modelData !== null + width: postsView.width - postsView.leftMargin - postsView.rightMargin + height: active ? item.implicitHeight : 0 - sourceComponent: PostContent { - post: modelData + sourceComponent: PostContent { + post: modelData - onCommentClicked: { - if (modelData) { - commentsDialog.targetPost = modelData - commentsDialog.open() - } + onCommentClicked: { + if (modelData) { + commentsDialog.targetPost = modelData + commentsDialog.open() } + } - onRepostClicked: { - if (modelData) { - repostMenu.targetPost = modelData - repostMenu.popup() - } + onRepostClicked: { + if (modelData) { + repostMenu.targetPost = modelData + repostMenu.popup() } } } + } - onCountChanged: { - if (atYEnd || count === 1) { + onCountChanged: { + if (atYEnd) { + Qt.callLater(() => { positionViewAtEnd() - } + }) } + } - Component.onCompleted: { - positionViewAtEnd() - } + Component.onCompleted: positionViewAtEnd() - ScrollBar.vertical: ScrollBar { - id: scrollBar - active: true - interactive: true - policy: ScrollBar.AsNeeded - - contentItem: Rectangle { - implicitWidth: 6 - radius: width / 2 - color: scrollBar.pressed ? Material.scrollBarPressedColor : - scrollBar.hovered ? Material.scrollBarHoveredColor : - Material.scrollBarColor - opacity: scrollBar.active ? 1 : 0 - - Behavior on opacity { - NumberAnimation { duration: 150 } - } - } - } - onContentHeightChanged: { - if (atYEnd) { - positionViewAtEnd() + ScrollBar.vertical: ScrollBar { + id: scrollBar + active: true + interactive: true + policy: ScrollBar.AsNeeded + + contentItem: Rectangle { + implicitWidth: 6 + radius: width / 2 + color: scrollBar.pressed ? Material.scrollBarPressedColor : + scrollBar.hovered ? Material.scrollBarHoveredColor : + Material.scrollBarColor + opacity: scrollBar.active ? 1 : 0 + + Behavior on opacity { + NumberAnimation { duration: 150 } } } } + } - // Input area for new public notes (at the bottom) - MessageInput { - placeholderText: qsTr("What's on your mind?") - buttonText: qsTr("Post") - onMessageSent: function(text) { - sendShortTextNote(text) - } + // Input area for new public notes (at the bottom) + MessageInput { + placeholderText: qsTr("What's on your mind?") + buttonText: qsTr("Post") + onMessageSent: function(text) { + sendShortTextNote(text) } } } // Private Chat View ColumnLayout { + Layout.fillWidth: true + Layout.fillHeight: true spacing: Constants.spacing_m DMRelays { @@ -276,7 +267,7 @@ Rectangle { } ListView { - id: messageListView + id: privateMessageListView Layout.fillWidth: true Layout.fillHeight: true clip: true @@ -284,6 +275,8 @@ Rectangle { layoutDirection: Qt.LeftToRight leftMargin: Constants.spacing_m rightMargin: Constants.spacing_m + spacing: Constants.spacing_m + bottomMargin: 0 visible: ctxRelayMgmt.dmRelays.length > 0 model: AutoListModel { @@ -291,15 +284,13 @@ Rectangle { source: privateMessages mode: AutoListModel.ByKey equalityTest: function (oldItem, newItem) { - return oldItem.content === newItem.content - && oldItem.isOwnMessage === newItem.isOwnMessage - && oldItem.timestamp === newItem.timestamp + return oldItem.id === newItem.id } } delegate: Loader { active: modelData !== undefined && modelData !== null - width: messageListView.width - messageListView.leftMargin - messageListView.rightMargin - 15 + width: privateMessageListView.width - privateMessageListView.leftMargin - privateMessageListView.rightMargin - 15 height: active ? item.height : 0 sourceComponent: Item { @@ -355,22 +346,33 @@ Rectangle { } onCountChanged: { - if (atYEnd || count === 1) { - positionViewAtEnd() + if (atYEnd) { + Qt.callLater(() => { + positionViewAtEnd() + }) } } - onContentHeightChanged: { - positionViewAtEnd() - } - - Component.onCompleted: { - positionViewAtEnd() - } + Component.onCompleted: positionViewAtEnd() ScrollBar.vertical: ScrollBar { + id: scrollBarPrivate active: true + interactive: true policy: ScrollBar.AsNeeded + + contentItem: Rectangle { + implicitWidth: 6 + radius: width / 2 + color: scrollBarPrivate.pressed ? Material.scrollBarPressedColor : + scrollBarPrivate.hovered ? Material.scrollBarHoveredColor : + Material.scrollBarColor + opacity: scrollBarPrivate.active ? 1 : 0 + + Behavior on opacity { + NumberAnimation { duration: 150 } + } + } } } diff --git a/src/Futr.hs b/src/Futr.hs index 0c479a6..4c2cd9f 100644 --- a/src/Futr.hs +++ b/src/Futr.hs @@ -236,9 +236,9 @@ runFutr = interpret $ \_ -> \case Nothing -> logError "Failed to create seal" >> return Nothing let validGiftWraps = catMaybes giftWraps + forM_ validGiftWraps $ \gw -> do - putEvent $ EventWithRelays gw Set.empty - publishGiftWrap gw senderPubKeyXO + publishGiftWrap gw senderPubKeyXO recipient notify $ emptyUpdates { privateMessagesChanged = True } (Nothing, _) -> logError "No key pair found" @@ -248,10 +248,11 @@ runFutr = interpret $ \_ -> \case kp <- getKeyPair now <- getCurrentTime let u = createShortTextNote input (keyPairToPubKeyXO kp) now + logDebug $ "Sending short text note: " <> input + logDebug $ "unsigned: " <> pack (show u) signed <- signEvent u kp case signed of Just s -> do - putEvent $ EventWithRelays s Set.empty publishToOutbox s notify $ emptyUpdates { postsChanged = True } Nothing -> logError "Failed to sign short text note" @@ -306,7 +307,6 @@ runFutr = interpret $ \_ -> \case let targetUris = eventRelayUris `Set.union` authorInboxUris `Set.union` relaySet - putEvent $ EventWithRelays s targetUris forM_ (Set.toList targetUris) $ \relay -> publishToRelay s relay notify $ emptyUpdates { postsChanged = True } @@ -327,7 +327,6 @@ runFutr = interpret $ \_ -> \case signed <- signEvent q kp case signed of Just s -> do - putEvent $ EventWithRelays s Set.empty publishToOutbox s notify $ emptyUpdates { postsChanged = True } Nothing -> logError "Failed to sign quote repost" @@ -359,7 +358,6 @@ runFutr = interpret $ \_ -> \case let targetUris = eventRelayUris `Set.union` authorInboxUris `Set.union` relaySet - putEvent $ EventWithRelays s targetUris forM_ (Set.toList targetUris) $ \relay -> publishToRelay s relay notify $ emptyUpdates { postsChanged = True } @@ -376,7 +374,6 @@ runFutr = interpret $ \_ -> \case signed <- signEvent deletion kp case signed of Just s -> do - putEvent $ EventWithRelays s Set.empty publishToOutbox s notify $ emptyUpdates { postsChanged = True, privateMessagesChanged = True } Nothing -> logError "Failed to sign event deletion" @@ -430,7 +427,6 @@ sendFollowListEvent follows = do signedEvent <- signEvent event kp case signedEvent of Just signedEvent' -> do - putEvent $ EventWithRelays signedEvent' Set.empty publishToOutbox signedEvent' Nothing -> logError "Failed to sign follow list event" diff --git a/src/Main.hs b/src/Main.hs index a8990f6..5c02e5a 100755 --- a/src/Main.hs +++ b/src/Main.hs @@ -25,6 +25,7 @@ import Store.Lmdb (LmdbState, initialLmdbState, runLmdbStore) import Types (AppState(..), RelayPool(..)) import Types qualified as Types + -- | Main function for the app. main :: IO () main = do diff --git a/src/Nostr/Event.hs b/src/Nostr/Event.hs index 5310a7a..dbdc189 100755 --- a/src/Nostr/Event.hs +++ b/src/Nostr/Event.hs @@ -84,28 +84,28 @@ createComment originalEvent content' rootScope parentItem relayHint xo t = -- Root scope tags rootTags = case root of Left (ITag val _) -> - [ ITag val relay + [ ITag val Nothing , KTag (pack $ show $ kind originalEvent) ] Right eid -> - [ ETag eid relay Nothing + [ ETag eid relay Nothing Nothing , KTag (pack $ show $ kind originalEvent) ] _ -> error "Invalid root scope tag" -- Parent tags (for replies) parentTags = case parent of - Just (ETag eid _ mpk) -> - [ ETag eid relay mpk + Just (ETag eid _ mpk _) -> + [ ETag eid relay mpk Nothing , KTag (pack $ show Comment) ] Just (ITag val _) -> - [ ITag val relay + [ ITag val Nothing , KTag (pack $ show $ kind originalEvent) ] Nothing -> case root of Left itag@(ITag _ _) -> [itag, KTag (pack $ show Comment)] - Right eid -> [ETag eid relay Nothing, KTag (pack $ show Comment)] + Right eid -> [ETag eid relay Nothing Nothing, KTag (pack $ show Comment)] _ -> [] _ -> error "Invalid parent tag" in @@ -119,7 +119,7 @@ createRepost event relayUrl xo t = { pubKey' = xo , createdAt' = t , kind' = Repost - , tags' = [ ETag (eventId event) (Just relayUrl) Nothing + , tags' = [ ETag (eventId event) (Just relayUrl) Nothing Nothing , PTag (pubKey event) Nothing Nothing ] , content' = decodeUtf8 $ toStrict $ encode event @@ -146,7 +146,7 @@ createGenericRepost event relayUrl xo t = { pubKey' = xo , createdAt' = t , kind' = GenericRepost - , tags' = [ ETag (eventId event) (Just relayUrl) Nothing + , tags' = [ ETag (eventId event) (Just relayUrl) Nothing Nothing , PTag (pubKey event) Nothing Nothing , KTag (pack $ show $ kind event) ] @@ -185,7 +185,7 @@ createReplyNote event note xo t = { pubKey' = xo , createdAt' = t , kind' = ShortTextNote - , tags' = [ETag (eventId event) Nothing (Just Reply)] + , tags' = [ETag (eventId event) Nothing (Just Reply) Nothing] , content' = note } @@ -213,7 +213,7 @@ createEventDeletion eids reason xo t = , content' = reason } where - toDelete = map (\eid -> ETag eid Nothing Nothing) eids + toDelete = map (\eid -> ETag eid Nothing Nothing Nothing) eids createRelayListMetadataEvent :: [Relay] -> PubKeyXO -> Int -> UnsignedEvent @@ -311,7 +311,7 @@ createGiftWrap sealEvent recipientPubKey = do { pubKey' = keyPairToPubKeyXO randomKeyPair , createdAt' = floor $ utcTimeToPOSIXSeconds currentTime , kind' = GiftWrap - , tags' = [PTag recipientPubKey Nothing Nothing] + , tags' = [PListTag [recipientPubKey]] , content' = wrapContent } signEvent wrapEvent randomKeyPair >>= \case @@ -385,18 +385,18 @@ getRootEventId = getRelationshipEventId Root -- | Get the relationship event ID. -getRelationshipEventId :: Relationship -> Event -> Maybe EventId +getRelationshipEventId :: Marker -> Event -> Maybe EventId getRelationshipEventId m e = if null replyList then Nothing else Just $ extractEventId $ head replyList where - replyFilter :: Relationship -> Tag -> Bool - replyFilter m' (ETag _ _ (Just m'')) = m' == m'' + replyFilter :: Marker -> Tag -> Bool + replyFilter m' (ETag _ _ (Just m'') _) = m' == m'' replyFilter _ _ = False replyList = filter (replyFilter m) $ tags e extractEventId :: Tag -> EventId - extractEventId (ETag eid _ _) = eid + extractEventId (ETag eid _ _ _) = eid extractEventId _ = error "Could not extract event id from reply or root tag" diff --git a/src/Nostr/InboxModel.hs b/src/Nostr/InboxModel.hs index 0e45723..cf05525 100644 --- a/src/Nostr/InboxModel.hs +++ b/src/Nostr/InboxModel.hs @@ -141,34 +141,28 @@ awaitAtLeastOneConnected' = do -- | 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 + else continueWithRelays inboxRelays -- | Initialize using default relays when no relay configuration exists initializeWithDefaultRelays :: InboxModelEff es => PubKeyXO -> Eff es () initializeWithDefaultRelays xo = do + logDebug "Initializing with default relays..." 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 @@ -187,7 +181,6 @@ initializeWithDefaultRelays xo = 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 @@ -212,14 +205,8 @@ initializeWithDefaultRelays xo = do -- Continue with appropriate relays inboxRelays <- getGeneralRelays xo - dmRelays <- getDMRelays xo - continueWithRelays followList inboxRelays dmRelays + continueWithRelays inboxRelays --- | 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 @@ -233,16 +220,26 @@ subscribeToFilter relays f queue = do let relayUri = getUri relay subscribe relayUri f queue --- | Collect events until EOSE is received +-- | Collect events until EOSE is received from all subscriptions 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 [] + st <- get @RelayPool + let expectedEoseCount = length $ Map.keys $ activeConnections st + + let loop acc eoseRelays = do + event@(relayUri, evt) <- atomically $ readTQueue queue + case evt of + SubscriptionEose -> + let newEoseRelays = Set.insert relayUri eoseRelays + in if Set.size newEoseRelays == expectedEoseCount -- All active relays have sent EOSE + then return (event : acc) + else loop (event : acc) newEoseRelays + SubscriptionClosed _ -> loop acc eoseRelays + _ -> loop (event : acc) eoseRelays + + if expectedEoseCount == 0 + then return [] + else loop [] Set.empty -- | Check if RelayListMetadata event is present hasRelayListMetadata :: [SubscriptionEvent] -> Bool @@ -259,11 +256,16 @@ hasPreferredDMRelays events = any isPreferredDMRelays events isPreferredDMRelays _ = False -- | Continue with discovered relays -continueWithRelays :: InboxModelEff es => [PubKeyXO] -> [Relay] -> [RelayURI] -> Eff es () -continueWithRelays followList inboxRelays dmRelays = do +continueWithRelays :: InboxModelEff es => [Relay] -> Eff es () +continueWithRelays inboxRelays = do kp <- getKeyPair let xo = keyPairToPubKeyXO kp + + inboxRelays <- getGeneralRelays xo let ownInboxRelayURIs = [ getUri relay | relay <- inboxRelays, isInboxCapable relay ] + + dmRelays <- getDMRelays xo + logDebug $ "Initializing subscriptions for Discovered Inbox Relays: " <> pack (show ownInboxRelayURIs) logDebug $ "Initializing subscriptions for Discovered DM Relays: " <> pack (show dmRelays) @@ -273,7 +275,6 @@ continueWithRelays followList inboxRelays dmRelays = do if connected then do subscribeToGiftwraps relay xo - logInfo $ "Subscribed to Giftwraps on relay: " <> relay else logError $ "Failed to connect to DM Relay: " <> relay @@ -284,24 +285,21 @@ continueWithRelays followList inboxRelays dmRelays = do if connected then do when (isInboxCapable relay) $ do - subscribeToMentionsAndProfiles relayUri xo - logInfo $ "Subscribed to Mentions on relay: " <> relayUri + subscribeToMentions relayUri xo 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) + follows <- getFollows xo + let followList = xo : map pubkey follows followRelayMap <- buildRelayPubkeyMap followList ownInboxRelayURIs - logDebug $ "Building Relay-PubKey Map: " <> pack (show followRelayMap) + logDebug $ "Build 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) + subscribeToProfilesAndPosts relayUri pubkeys else logError $ "Failed to connect to Follow Relay: " <> relayUri @@ -309,21 +307,21 @@ continueWithRelays followList inboxRelays dmRelays = do subscribeToGiftwraps :: InboxModelEff es => RelayURI -> PubKeyXO -> Eff es () subscribeToGiftwraps relayUri xo = do lastTimestamp <- getSubscriptionTimestamp [xo] [GiftWrap] + let lastTimestamp' = fmap (\ts -> ts - (2 * 24 * 60 * 60)) lastTimestamp -- 2 days in seconds queue <- gets @RelayPool inboxQueue - void $ subscribe relayUri (giftWrapFilter xo lastTimestamp) queue + void $ subscribe relayUri (giftWrapFilter xo lastTimestamp') queue -- | Subscribe to mentions on a relay -subscribeToMentionsAndProfiles :: InboxModelEff es => RelayURI -> PubKeyXO -> Eff es () -subscribeToMentionsAndProfiles relayUri xo = do +subscribeToMentions :: InboxModelEff es => RelayURI -> PubKeyXO -> Eff es () +subscribeToMentions 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 +subscribeToProfilesAndPosts :: InboxModelEff es => RelayURI -> [PubKeyXO] -> Eff es () +subscribeToProfilesAndPosts relayUri pks = do -- Subscribe to profiles queue <- gets @RelayPool inboxQueue void $ subscribe relayUri (profilesFilter pks Nothing) queue @@ -375,7 +373,7 @@ eventLoop xo = do case event of EventAppeared event' -> do updates <- handleEvent relayUri event' - when (followsChanged updates || dmRelaysChanged updates || generalRelaysChanged updates) $ do + when (myFollowsChanged updates || dmRelaysChanged updates || generalRelaysChanged updates) $ do updateSubscriptions xo notify updates SubscriptionEose -> return () @@ -413,7 +411,7 @@ updateGeneralSubscriptions xo = do when (isInboxCapable relay) $ do let relayUri = getUri relay connected <- connect relayUri - when connected $ subscribeToMentionsAndProfiles relayUri xo + when connected $ subscribeToMentions relayUri xo newRelayPubkeyMap <- buildRelayPubkeyMap followList ownInboxRelayURIs @@ -432,14 +430,14 @@ updateGeneralSubscriptions xo = do let pubkeys = Map.findWithDefault [] relayUri newRelayPubkeyMap connected <- connect relayUri when connected $ do - subscribeToRelay relayUri pubkeys + subscribeToProfilesAndPosts 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) + subscribeToProfilesAndPosts relayUri (Set.toList newPubkeys) -- | Update DM subscriptions updateDMSubscriptions :: InboxModelEff es => PubKeyXO -> Eff es () diff --git a/src/Nostr/Publisher.hs b/src/Nostr/Publisher.hs index 1d57cee..859e3de 100644 --- a/src/Nostr/Publisher.hs +++ b/src/Nostr/Publisher.hs @@ -1,6 +1,6 @@ module Nostr.Publisher where -import Control.Monad (forM, forM_, when) +import Control.Monad (forM, forM_, void, when) import Data.List (nub, partition) import Data.Map.Strict qualified as Map import Data.Set qualified as Set @@ -38,7 +38,7 @@ data Publisher :: Effect where Broadcast :: Event -> Publisher m () PublishToOutbox :: Event -> Publisher m () PublishToRelay :: Event -> RelayURI -> Publisher m () - PublishGiftWrap :: Event -> PubKeyXO -> Publisher m () + PublishGiftWrap :: Event -> PubKeyXO -> PubKeyXO -> Publisher m () -- sender, recipient GetPublishResult :: EventId -> Publisher m PublishResult type instance DispatchOf Publisher = Dynamic @@ -66,7 +66,7 @@ runPublisher -> Eff es a runPublisher = interpret $ \_ -> \case Broadcast event' -> do - putEvent $ EventWithRelays event' Set.empty + void $ putEvent $ EventWithRelays event' Set.empty kp <- getKeyPair let xo = keyPairToPubKeyXO kp @@ -106,7 +106,7 @@ runPublisher = interpret $ \_ -> \case disconnect r PublishToOutbox event' -> do - putEvent $ EventWithRelays event' Set.empty + void $ putEvent $ EventWithRelays event' Set.empty kp <- getKeyPair let pk = keyPairToPubKeyXO kp @@ -124,7 +124,7 @@ runPublisher = interpret $ \_ -> \case forM_ outboxCapableURIs $ \r -> writeToChannel event' r PublishToRelay event' relayUri' -> do - putEvent $ EventWithRelays event' $ Set.empty + void $ putEvent $ EventWithRelays event' $ Set.empty modify $ \st -> st { publishStatus = Map.adjust (\existingMap -> Map.insert relayUri' Publishing existingMap) @@ -133,10 +133,10 @@ runPublisher = interpret $ \_ -> \case } writeToChannel event' relayUri' - PublishGiftWrap event' senderPk -> do - putEvent $ EventWithRelays event' Set.empty + PublishGiftWrap event' senderPk recipientPk -> do + void $ putEvent $ EventWithRelays event' Set.empty dmRelayList <- getDMRelays senderPk - recipientDMRelays <- getDMRelays (pubKey event') + recipientDMRelays <- getDMRelays recipientPk if null dmRelayList || null recipientDMRelays then pure () diff --git a/src/Nostr/RelayConnection.hs b/src/Nostr/RelayConnection.hs index ab08d86..33d280c 100644 --- a/src/Nostr/RelayConnection.hs +++ b/src/Nostr/RelayConnection.hs @@ -196,7 +196,6 @@ nostrClient connectionMVar r requestChan runE conn = runE $ do 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' -> @@ -226,6 +225,7 @@ nostrClient connectionMVar r requestChan runE conn = runE $ do receiveLoop conn' q Left err -> do logError $ "Could not decode server response from " <> r <> ": " <> T.pack err + logError $ "Msg: " <> T.pack (show msg') receiveLoop conn' q sendLoop conn' = do @@ -384,7 +384,7 @@ handleResponse relayURI' r = case r of 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 + Nothing -> error $ "2 No subscription found for " <> show subId' -- <> " with response: " <> show r -- | Handle authentication required. diff --git a/src/Nostr/Subscription.hs b/src/Nostr/Subscription.hs index f606def..2754594 100644 --- a/src/Nostr/Subscription.hs +++ b/src/Nostr/Subscription.hs @@ -77,6 +77,7 @@ runSubscription -> Eff es a runSubscription = interpret $ \_ -> \case Subscribe r f queue -> do + logDebug $ "Subscribing to relay: " <> r <> " with filter: " <> pack (show f) subId' <- generateRandomSubscriptionId let sub = SubscriptionDetails subId' f queue 0 0 r st <- get @RelayPool @@ -86,12 +87,10 @@ runSubscription = interpret $ \_ -> \case 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 @@ -125,16 +124,11 @@ runSubscription = interpret $ \_ -> \case else do wasUpdated <- putEvent ev updates <- case kind event' of - ShortTextNote -> + ShortTextNote -> do 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 + Repost -> do + pure $ emptyUpdates { postsChanged = wasUpdated } EventDeletion -> pure $ emptyUpdates { postsChanged = wasUpdated, privateMessagesChanged = wasUpdated } @@ -154,43 +148,17 @@ runSubscription = interpret $ \_ -> \case FollowList -> do kp <- getKeyPair - let pk = keyPairToPubKeyXO kp + 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 } + 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 } + pure $ emptyUpdates { dmRelaysChanged = wasUpdated } _ -> do logDebug $ "Ignoring event of kind: " <> pack (show (kind event')) @@ -245,7 +213,7 @@ generateRandomSubscriptionId = do profilesFilter :: [PubKeyXO] -> Maybe Int -> Filter profilesFilter authors lastTimestamp = emptyFilter { authors = Just authors - , kinds = Just [RelayListMetadata, PreferredDMRelays, FollowList] + , kinds = Just [RelayListMetadata, PreferredDMRelays, FollowList, Metadata] , since = lastTimestamp } diff --git a/src/Nostr/Types.hs b/src/Nostr/Types.hs index c94a961..2f1fecb 100644 --- a/src/Nostr/Types.hs +++ b/src/Nostr/Types.hs @@ -32,7 +32,7 @@ import Network.URI (URI(..), parseURI, uriAuthority, uriRegName, uriScheme) import Prelude hiding (until) import Text.Read (readMaybe) -import Nostr.Keys (PubKeyXO(..), Signature, byteStringToHex, exportPubKeyXO, exportSignature) +import Nostr.Keys (PubKeyXO(..), Signature, byteStringToHex, exportPubKeyXO, exportSignature, importPubKeyXO) -- | Represents a relay URI. type RelayURI = Text @@ -216,8 +216,8 @@ instance Ord Kind where newtype EventId = EventId { getEventId :: ByteString } deriving (Eq, Ord) --- | Represents a relationship type. -data Relationship = Reply | Root | Mention +-- | Represents a marker type. +data Marker = Reply | Root | Mention deriving (Eq, Generic, Show) @@ -237,8 +237,9 @@ data ExternalId -- | Represents a tag in an event. data Tag - = ETag EventId (Maybe RelayURI) (Maybe Relationship) + = ETag EventId (Maybe RelayURI) (Maybe Marker) (Maybe PubKeyXO) | PTag PubKeyXO (Maybe RelayURI) (Maybe DisplayName) + | PListTag [PubKeyXO] | QTag EventId (Maybe RelayURI) (Maybe PubKeyXO) | KTag Text | RTag Relay @@ -447,13 +448,13 @@ instance FromJSON Tag where parseJSON v@(Array arr) = case V.toList arr of ("e":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseETag rest) v - ("p":rest) -> parsePTag rest v - ("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 + ("p":rest) -> either (const $ parseGenericTag v) return $ parseEither (parsePTag rest) v + ("q":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseQTag rest) v + ("i":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseITag rest) v + ("k":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseKTag rest) v + ("r":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseRTag rest) v + ("relay":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseRelayTag rest) v + ("challenge":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseChallengeTag rest) v _ -> parseGenericTag v parseJSON v = parseGenericTag v @@ -462,24 +463,43 @@ instance FromJSON Tag where parseETag :: [Value] -> Value -> Parser Tag parseETag rest _ = do case rest of + [eventIdVal, relayVal, markerVal, pubkeyVal] -> do + eventId <- parseJSONSafe eventIdVal + relay <- parseMaybeRelayURI relayVal + marker <- parseMaybeMarker markerVal + pubkey <- parseMaybePubKey pubkeyVal + return $ ETag eventId relay marker pubkey [eventIdVal, relayVal, markerVal] -> do eventId <- parseJSONSafe eventIdVal relay <- parseMaybeRelayURI relayVal - marker <- parseMaybeRelationship markerVal - return $ ETag eventId relay marker + marker <- parseMaybeMarker markerVal + return $ ETag eventId relay marker Nothing [eventIdVal, relayVal] -> do eventId <- parseJSONSafe eventIdVal relay <- parseMaybeRelayURI relayVal - return $ ETag eventId relay Nothing + return $ ETag eventId relay Nothing Nothing [eventIdVal] -> do eventId <- parseJSONSafe eventIdVal - return $ ETag eventId Nothing Nothing + return $ ETag eventId Nothing Nothing Nothing _ -> fail "Invalid ETag format" -- | Parses a PTag from a JSON array. parsePTag :: [Value] -> Value -> Parser Tag -parsePTag rest _ = case rest of +parsePTag rest v = do + -- First try to parse as PListTag (multiple pubkeys) + case rest of + -- If all values are strings, try parsing as PListTag + values@(_:_) -> + (do + pubkeys <- mapM parseJSONSafe values + return $ PListTag pubkeys) + <|> parseSinglePTag rest v -- Fallback to single PTag parsing + _ -> parseSinglePTag rest v + +-- | Parses a single PTag (with optional relay and name) +parseSinglePTag :: [Value] -> Value -> Parser Tag +parseSinglePTag rest _ = case rest of (pubkeyVal : maybeRelay : maybeName : _) -> do pubkey <- parseJSONSafe pubkeyVal relay <- parseMaybeRelayURI maybeRelay @@ -492,7 +512,7 @@ parsePTag rest _ = case rest of (pubkeyVal : _) -> do pubkey <- parseJSONSafe pubkeyVal return $ PTag pubkey Nothing Nothing - _ -> fail "Invalid PTag format" + [] -> fail "Invalid PTag format: empty array" -- | Parses a JSON value safely and returns the parsed result. @@ -509,10 +529,10 @@ parseMaybeRelayURI Null = pure Nothing parseMaybeRelayURI _ = fail "Expected string or null for RelayURI" --- | Parses a maybe relationship from a JSON value. -parseMaybeRelationship :: Value -> Parser (Maybe Relationship) -parseMaybeRelationship Null = return Nothing -parseMaybeRelationship v = (Just <$> parseJSONSafe v) <|> return Nothing +-- | Parses a maybe marker from a JSON value. +parseMaybeMarker :: Value -> Parser (Maybe Marker) +parseMaybeMarker Null = return Nothing +parseMaybeMarker v = (Just <$> parseJSONSafe v) <|> return Nothing -- | Parses a maybe display name from a JSON value. @@ -570,7 +590,7 @@ parseGenericTag v = fail $ "Expected array for generic tag, got: " ++ show v -- | Converts a 'Tag' to its JSON representation. instance ToJSON Tag where toEncoding tag = case tag of - ETag eventId relayURL marker -> + ETag eventId relayURL marker pubkey -> list id $ [ text "e" , text $ decodeUtf8 $ B16.encode $ getEventId eventId @@ -580,7 +600,8 @@ instance ToJSON Tag where Just Reply -> [text "reply"] Just Root -> [text "root"] Just Mention -> [text "mention"] - Nothing -> []) + Nothing -> []) ++ + (maybe [] (\pk -> [text $ decodeUtf8 $ B16.encode $ exportPubKeyXO pk]) pubkey) PTag xo relayURL name -> list id $ [ text "p" @@ -588,6 +609,8 @@ instance ToJSON Tag where ] ++ (maybe [] (\r -> [text r]) relayURL) ++ (maybe [] (\n -> [text n]) name) + PListTag pubkeys -> + list id $ text "p" : map toEncoding pubkeys QTag eventId relayURL pubkey -> list id $ [ text "q" @@ -613,9 +636,9 @@ instance ToJSON Tag where GenericTag values -> list toEncoding values --- | Converts a JSON string into a 'Relationship'. -instance FromJSON Relationship where - parseJSON = withText "Relationship" $ \m -> do +-- | Converts a JSON string into a 'Marker'. +instance FromJSON Marker where + parseJSON = withText "Marker" $ \m -> do case T.toLower m of "reply" -> return Reply "root" -> return Root @@ -623,8 +646,8 @@ instance FromJSON Relationship where _ -> mzero --- | Converts a 'Relationship' to its JSON representation. -instance ToJSON Relationship where +-- | Converts a 'Marker' to its JSON representation. +instance ToJSON Marker where toEncoding Reply = text "reply" toEncoding Root = text "root" toEncoding Mention = text "mention" @@ -896,3 +919,11 @@ instance FromJSON ExternalId where instance ToJSON ExternalId where toEncoding = text . externalIdToText toJSON = String . externalIdToText + +-- | Parses a maybe pubkey from a JSON value. +parseMaybePubKey :: Value -> Parser (Maybe PubKeyXO) +parseMaybePubKey Null = return Nothing +parseMaybePubKey (String s) = case decodeHex s of + Just bs | BS.length bs == 32 -> return $ importPubKeyXO bs + _ -> fail "Invalid pubkey format" +parseMaybePubKey _ = fail "Expected string or null for pubkey" diff --git a/src/Store/Lmdb.hs b/src/Store/Lmdb.hs index b0acc04..83cfd67 100644 --- a/src/Store/Lmdb.hs +++ b/src/Store/Lmdb.hs @@ -31,9 +31,8 @@ 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 (catMaybes, mapMaybe) +import Data.Maybe (catMaybes) import Data.Set qualified as Set -import Data.Text (unpack) import Data.Text.Encoding (encodeUtf8) import Effectful import Effectful.Dispatch.Dynamic @@ -44,7 +43,6 @@ 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 ((>->)) @@ -78,7 +76,7 @@ data LmdbState = LmdbState , dmRelaysDb :: Database PubKeyXO ([RelayURI], Int) , latestTimestampDb :: Database (PubKeyXO, Kind) Int , eventCache :: LRU.LRU EventId EventWithRelays - , profileCache :: LRU.LRU PubKeyXO (Profile, Int) + , profileCache :: LRU.LRU PubKeyXO Profile , followsCache :: LRU.LRU PubKeyXO [Follow] , timelineCache :: LRU.LRU (TimelineType, PubKeyXO, Int) [EventId] , generalRelaysCache :: LRU.LRU PubKeyXO ([Relay], Int) @@ -119,17 +117,11 @@ runLmdbStore = interpret $ \_ -> \case currentState <- get @LmdbState kp <- getKeyPair - wasUpdated <- liftIO $ withMVar (lmdbLock currentState) $ \_ -> withTransaction (lmdbEnv currentState) $ \txn -> do + wasUpdated <- withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> + liftIO $ withMVar (lmdbLock currentState) $ \_ -> + withTransaction (lmdbEnv currentState) $ \txn -> do Map.repsert' txn (eventDb currentState) (eventId $ event ev) ev - 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 @@ -141,11 +133,21 @@ runLmdbStore = interpret $ \_ -> \case case mDecryptedRumor of Just decryptedRumor | pubKey sealedEvent == rumorPubKey decryptedRumor -> do - let participants = if rumorPubKey decryptedRumor == keyPairToPubKeyXO kp - then sort $ getAllPTags (rumorTags decryptedRumor) + let tags' = rumorTags decryptedRumor + pListPks = getAllPListTags tags' + participants = if rumorPubKey decryptedRumor == keyPairToPubKeyXO kp + then sort pListPks else filter (/= keyPairToPubKeyXO kp) - (rumorPubKey decryptedRumor : sort (getAllPTags (rumorTags decryptedRumor))) + (rumorPubKey decryptedRumor : sort pListPks) + addTimelineEntryTx txn (chatTimelineDb currentState) ev participants (rumorCreatedAt decryptedRumor) + runE $ modify @LmdbState $ \s -> s + { timelineCache = foldr (\p cache -> + removeAuthorTimelineEntries ChatTimeline p cache) + (timelineCache s) + participants + } + pure True _ -> pure False _ -> pure False @@ -153,22 +155,28 @@ runLmdbStore = interpret $ \_ -> \case ShortTextNote -> do addTimelineEntryTx txn (postTimelineDb currentState) ev [author] eventTimestamp + runE $ modify @LmdbState $ \s -> s + { timelineCache = removeAuthorTimelineEntries PostTimeline author (timelineCache s) } + pure True Repost -> do - let etags = [t | t@(ETag _ _ _) <- tags (event ev)] + let etags = [t | t@(ETag _ _ _ _) <- tags (event ev)] mOriginalEvent = eitherDecode (fromStrict $ encodeUtf8 $ content $ event ev) case (etags, mOriginalEvent) of - (ETag _ _ _ : _, Right originalEvent) + (ETag _ _ _ _ : _, Right originalEvent) | validateEvent originalEvent -> do Map.repsert' txn (eventDb currentState) (eventId originalEvent) (EventWithRelays originalEvent Set.empty) addTimelineEntryTx txn (postTimelineDb currentState) ev [author] eventTimestamp + runE $ modify @LmdbState $ \s -> s + { timelineCache = removeAuthorTimelineEntries PostTimeline author (timelineCache s) } + pure True _ -> pure False EventDeletion -> do - let eventIdsToDelete = [eid | ETag eid _ _ <- tags (event ev)] + let eventIdsToDelete = [eid | ETag eid _ _ _ <- tags (event ev)] res <- forM eventIdsToDelete $ \eid -> do mEvent <- Map.lookup' (readonly txn) (eventDb currentState) eid case mEvent of @@ -179,7 +187,7 @@ runLmdbStore = interpret $ \_ -> \case Repost -> Just $ postTimelineDb currentState GiftWrap -> Just $ chatTimelineDb currentState _ -> Nothing - + result <- case timelineDb of Just db -> do Map.delete' txn db key @@ -187,6 +195,13 @@ runLmdbStore = interpret $ \_ -> \case pure True Nothing -> pure False + runE $ modify @LmdbState $ \s -> s + { eventCache = fst (LRU.delete eid (eventCache s)) + , timelineCache = + removeAuthorTimelineEntries PostTimeline author $ + removeAuthorTimelineEntries ChatTimeline author (timelineCache s) + } + pure result Nothing -> pure False @@ -196,22 +211,41 @@ runLmdbStore = interpret $ \_ -> \case Metadata -> do case eitherDecode (fromStrict $ encodeUtf8 $ content $ event ev) of Right profile -> do - Map.repsert' txn (profileDb currentState) author (profile, eventTimestamp) - pure True + existingProfile <- Map.lookup' (readonly txn) (profileDb currentState) author + case existingProfile of + Just (_, existingTs) -> + if eventTimestamp > existingTs then do + Map.repsert' txn (profileDb currentState) author (profile, eventTimestamp) + updateState + pure True + else pure False + Nothing -> do + Map.repsert' txn (profileDb currentState) author (profile, eventTimestamp) + updateState + pure True Left _ -> pure False + where + updateState = runE $ modify @LmdbState $ \s -> s + { profileCache = fst $ LRU.delete author (profileCache s) } FollowList -> do let followList' = [Follow pk petName' | PTag pk _ petName' <- tags (event ev)] - existingTimestamp <- Map.lookup' (readonly txn) (latestTimestampDb currentState) (author, eventKind) - case existingTimestamp of + 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' + updateState pure True - else pure False + else do + pure False Nothing -> do Map.repsert' txn (followsDb currentState) author followList' + updateState pure True + where + updateState = runE $ modify @LmdbState $ \s -> s + { followsCache = fst $ LRU.delete author (followsCache s) } PreferredDMRelays -> do let validRelayTags = [ r' | RelayTag r' <- tags (event ev), isValidRelayURI r' ] @@ -223,11 +257,16 @@ runLmdbStore = interpret $ \_ -> \case Just (_, existingTs) -> if eventTimestamp > existingTs then do Map.repsert' txn (dmRelaysDb currentState) author (relays, eventTimestamp) + updateState pure True else pure False Nothing -> do Map.repsert' txn (dmRelaysDb currentState) author (relays, eventTimestamp) + updateState pure True + where + updateState = runE $ modify @LmdbState $ \s -> s + { dmRelaysCache = fst $ LRU.delete author (dmRelaysCache s) } RelayListMetadata -> do let validRelayTags = [ r' | RTag r' <- tags (event ev), isValidRelayURI (getUri r') ] @@ -239,61 +278,32 @@ runLmdbStore = interpret $ \_ -> \case Just (_, existingTs) -> if eventTimestamp > existingTs then do Map.repsert' txn (generalRelaysDb currentState) author (relays, eventTimestamp) + updateState pure True else pure False Nothing -> do Map.repsert' txn (generalRelaysDb currentState) author (relays, eventTimestamp) + updateState pure True + where + updateState = runE $ modify @LmdbState $ \s -> s + { generalRelaysCache = fst $ LRU.delete author (generalRelaysCache s) } - _ -> 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) } + _ -> pure False - 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) } + when wasUpdated $ do + liftIO $ withMVar (lmdbLock currentState) $ \_ -> withTransaction (lmdbEnv currentState) $ \txn -> do + 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 - _ -> pure () + modify @LmdbState $ \s -> s + { eventCache = fst $ LRU.delete (eventId $ event ev) (eventCache s) } pure wasUpdated @@ -332,26 +342,25 @@ runLmdbStore = interpret $ \_ -> \case GetProfile pk -> do st <- get @LmdbState case LRU.lookup pk (profileCache st) of - (newCache, Just (profile, _)) -> do - modify @LmdbState $ \s -> s { profileCache = newCache } - pure profile + (_, Just profile) -> pure profile (_, Nothing) -> do mp <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> do Map.lookup' (readonly txn) (profileDb st) pk let (profile, _) = maybe (emptyProfile, 0) id mp - modify @LmdbState $ \s -> s { profileCache = LRU.insert pk (profile, 0) $ profileCache s } + modify @LmdbState $ \s -> s { profileCache = LRU.insert pk profile $ profileCache s } pure profile GetTimelineIds timelineType author limit -> do st <- get @LmdbState let cacheKey = (timelineType, author, limit) case LRU.lookup cacheKey (timelineCache st) of - (newCache, Just ids) -> do - modify @LmdbState $ \s -> s { timelineCache = newCache } + (_, Just ids) -> do pure ids (_, Nothing) -> do + -- Add debug logging + liftIO $ putStrLn $ "GetTimelineIds: type=" ++ show timelineType ++ " author=" ++ show author ids <- liftIO $ withTransaction (lmdbEnv st) $ \txn -> - withCursor (readonly txn) (if timelineType == PostTimeline then postTimelineDb st else chatTimelineDb st) $ \cursor -> + withCursor (readonly txn) (if timelineType == PostTimeline then postTimelineDb st else chatTimelineDb st) $ \cursor -> do Pipes.toListM $ Map.lastBackward cursor >-> Pipes.filter (\kv -> fst (keyValueKey kv) == author) @@ -509,11 +518,11 @@ latestTimestampDbSettings = makeSettings -- | Get all p tags from the rumor tags -getAllPTags :: [Tag] -> [PubKeyXO] -getAllPTags = mapMaybe extractPubKey +getAllPListTags :: [Tag] -> [PubKeyXO] +getAllPListTags = concatMap extractPubKeys where - extractPubKey (PTag pk _ _) = Just pk - extractPubKey _ = Nothing + extractPubKeys (PListTag pks) = pks + extractPubKeys _ = [] -- | Initialize LMDB state initializeLmdbState :: FilePath -> IO LmdbState @@ -577,3 +586,12 @@ initialLmdbState = LmdbState , dmRelaysCache = LRU.newLRU (Just smallCacheSize) , latestTimestampCache = LRU.newLRU (Just smallCacheSize) } + +-- | Remove timeline entries for a given author +removeAuthorTimelineEntries :: TimelineType -> PubKeyXO -> LRU.LRU (TimelineType, PubKeyXO, Int) [EventId] -> LRU.LRU (TimelineType, PubKeyXO, Int) [EventId] +removeAuthorTimelineEntries timelineType author cache = + let entries = LRU.toList cache + newEntries = [(k, v) | (k@(tt, pk, _), v) <- entries, tt /= timelineType || pk /= author] + in case LRU.maxSize cache of + Just maxSize -> LRU.fromList (Just maxSize) newEntries + Nothing -> LRU.fromList Nothing newEntries diff --git a/src/UI.hs b/src/UI.hs index 17758c3..2c64f92 100644 --- a/src/UI.hs +++ b/src/UI.hs @@ -34,7 +34,7 @@ import Nostr.Event (createMetadata) import Nostr.Publisher import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) import Nostr.Types ( Event(..), EventId(..), Kind(..), Profile(..), RelayURI - , Relationship(..), Rumor(..), Tag(..) ) + , Marker(..), Rumor(..), Tag(..) ) import Nostr.Util import Presentation.KeyMgmtUI qualified as KeyMgmtUI import Presentation.RelayMgmtUI qualified as RelayMgmtUI @@ -164,13 +164,13 @@ runUI = interpret $ \_ -> \case followPool <- newFactoryPool (newObject followClass) let getRootReference evt = - case find (\case ETag _ _ (Just Root) -> True; _ -> False) (tags evt) of - Just (ETag eid _ _) -> return $ Just eid + case find (\case ETag _ _ (Just Root) _ -> True; _ -> False) (tags evt) of + Just (ETag eid _ _ _) -> return $ Just eid _ -> return Nothing getParentReference evt = - case find (\case ETag _ _ (Just Reply) -> True; _ -> False) (tags evt) of - Just (ETag eid _ _) -> return $ Just eid + case find (\case ETag _ _ (Just Reply) _ -> True; _ -> False) (tags evt) of + Just (ETag eid _ _ _) -> return $ Just eid _ -> return Nothing {- getEventCount subscriber postId = do @@ -279,7 +279,7 @@ runUI = interpret $ \_ -> \case case eventMaybe of Just eventWithRelays -> do let ev = event eventWithRelays - eTagRefs = [tagId | ETag tagId _ _ <- tags ev] + eTagRefs = [tagId | ETag tagId _ _ _ <- tags ev] qTagRefs = [tagId | QTag tagId _ _ <- tags ev] contentRefs = extractNostrReferences (content ev) allRefs = nub $ eTagRefs ++ qTagRefs ++ contentRefs @@ -357,7 +357,6 @@ runUI = interpret $ \_ -> \case case signedMaybe of Just signed -> do runE $ broadcast signed - runE $ logInfo "Profile successfully saved and sent to relay pool" Nothing -> runE $ logWarning "Failed to sign profile update event", defPropertySigRO' "followList" changeKey' $ \obj -> do