diff --git a/futr.cabal b/futr.cabal index f5af8de..4c3f43e 100755 --- a/futr.cabal +++ b/futr.cabal @@ -40,12 +40,15 @@ executable futr Nostr.GiftWrap Nostr.Keys Nostr.Profile + Nostr.Publisher + Nostr.RelayConnection Nostr.RelayPool Nostr.Subscription - Nostr.WebSocket Nostr.Types Nostr.Util Presentation.KeyMgmt + Presentation.RelayMgmt + RelayMgmt Types TimeFormatter UI @@ -97,6 +100,7 @@ executable futr libsecp256k1 >=0.2.1 && <0.3, memory >=0.18 && <0.19, network >= 3.2.4.0 && <3.3, + network-uri >=2.6.4.2 && <2.7, random >=1.2.1.2 && <1.3, scientific >=0.3.8.0 && <0.4, stm >=2.5.1.0 && <2.6, diff --git a/resources/icons/cancel.svg b/resources/icons/cancel.svg new file mode 100644 index 0000000..f783096 --- /dev/null +++ b/resources/icons/cancel.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/icons/check_circle.svg b/resources/icons/check_circle.svg new file mode 100644 index 0000000..76be073 --- /dev/null +++ b/resources/icons/check_circle.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/icons/error.svg b/resources/icons/error.svg new file mode 100644 index 0000000..22625b2 --- /dev/null +++ b/resources/icons/error.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/icons/save.svg b/resources/icons/save.svg new file mode 100644 index 0000000..9fcc770 --- /dev/null +++ b/resources/icons/save.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/icons/sync.svg b/resources/icons/sync.svg new file mode 100644 index 0000000..4d2d2ea --- /dev/null +++ b/resources/icons/sync.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/icons/wifi.svg b/resources/icons/wifi.svg new file mode 100644 index 0000000..6ca5e55 --- /dev/null +++ b/resources/icons/wifi.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/icons/wifi_off.svg b/resources/icons/wifi_off.svg new file mode 100644 index 0000000..3f08eb4 --- /dev/null +++ b/resources/icons/wifi_off.svg @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/resources/qml/content/Chat.ui.qml b/resources/qml/content/Chat.ui.qml index f80f4f7..27d55a4 100644 --- a/resources/qml/content/Chat.ui.qml +++ b/resources/qml/content/Chat.ui.qml @@ -64,6 +64,7 @@ Rectangle { model: AutoListModel { id: messagesModel source: messages + mode: AutoListModel.ByKey } delegate: Item { @@ -79,7 +80,7 @@ Rectangle { } width: Math.min(Math.max(messageContent.implicitWidth, timestampText.implicitWidth) + 24, parent.width * 0.8) height: messageContent.height + timestampText.height + 20 - color: modelData && modelData.isOwnMessage ? Material.accentColor : Material.dividerColor + color: modelData.isOwnMessage ? Material.accentColor : Material.dividerColor radius: 10 ColumnLayout { diff --git a/resources/qml/content/DMRelays.ui.qml b/resources/qml/content/DMRelays.ui.qml new file mode 100644 index 0000000..70704d2 --- /dev/null +++ b/resources/qml/content/DMRelays.ui.qml @@ -0,0 +1,46 @@ +import QtQuick 2.15 +import QtQuick.Controls 2.15 +import QtQuick.Controls.Material 2.15 +import QtQuick.Layouts 1.15 +import QtGraphicalEffects 1.15 + +import Futr 1.0 + +Rectangle { + id: root + color: Material.backgroundColor + radius: 5 + border.color: Material.dividerColor + border.width: 1 + + property bool hasValidInputs: false + + ColumnLayout { + anchors.left: parent.left + anchors.right: parent.right + anchors.top: parent.top + anchors.margins: 10 + spacing: 10 + + Text { + Layout.fillWidth: true + text: qsTr("You are not set up to receive private messsages yet.") + font: Constants.largeFont + color: Material.foreground + wrapMode: Text.WordWrap + } + + Button { + text: qsTr("Setup now") + onClicked: relayMgmtDialog.open() + } + + Text { + Layout.fillWidth: true + text: qsTr("If you believe this message is incorrect, it might be because we can't access your preferred DM relays from your profile, your internet connection is slow, or the necessary settings file is missing from your computer.") + font: Constants.smallFont + color: Material.foreground + wrapMode: Text.WordWrap + } + } +} diff --git a/resources/qml/content/Dialogs/LoginErrorDialog.ui.qml b/resources/qml/content/Dialogs/LoginErrorDialog.ui.qml index ba29a09..85c26c6 100644 --- a/resources/qml/content/Dialogs/LoginErrorDialog.ui.qml +++ b/resources/qml/content/Dialogs/LoginErrorDialog.ui.qml @@ -8,19 +8,21 @@ Dialog { standardButtons: Dialog.Ok modal: true anchors.centerIn: parent + width: Math.min(parent.width - 40, 300) + height: 160 property string errorMessage: "" - width: Math.min(parent.width - 200, 400) - height: Math.min(contentColumn.implicitHeight + 80, parent.height - 40) - ColumnLayout { id: contentColumn - width: parent.width - spacing: 10 + anchors.fill: parent + anchors.margins: 0 Text { Layout.fillWidth: true + Layout.alignment: Qt.AlignLeft + Layout.preferredWidth: contentColumn.width + horizontalAlignment: Text.AlignLeft text: errorMessage color: Material.foreground font.pixelSize: 14 diff --git a/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml b/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml new file mode 100644 index 0000000..38c47b5 --- /dev/null +++ b/resources/qml/content/Dialogs/RelayMgmtDialog.ui.qml @@ -0,0 +1,430 @@ +import QtQuick 2.15 +import QtQuick.Controls 2.15 +import QtQuick.Controls.Material 2.15 +import QtQuick.Layouts 1.15 +import QtGraphicalEffects 1.15 + +import Futr 1.0 +import HsQML.Model 1.0 +import "../." + +Dialog { + standardButtons: Dialog.Close + modal: true + anchors.centerIn: parent + + id: relayMgmtDialog + width: 800 + height: 700 + + ColumnLayout { + anchors.fill: parent + anchors.margins: 10 + spacing: 10 + Layout.fillWidth: true + + Text { + text: qsTr("Relay Management") + font: Constants.largeFont + color: Material.primaryTextColor + Layout.alignment: Qt.AlignHCenter + } + + ColumnLayout { + Layout.fillWidth: true + Layout.fillHeight: true + + Text { + text: qsTr("Preferred DM Relays") + font: Constants.font + color: Material.primaryTextColor + Layout.alignment: Qt.AlignLeft + } + + ColumnLayout { + Layout.fillWidth: true + Layout.fillHeight: true + + ListView { + id: dmRelaysListView + Layout.fillWidth: true + Layout.fillHeight: true + clip: true + + ScrollBar.vertical: ScrollBar { + policy: ScrollBar.AsNeeded + active: true + } + + model: AutoListModel { + source: ctxRelayMgmt.dmRelays + mode: AutoListModel.ByKey + equalityTest: function (oldItem, newItem) { + return oldItem.url === newItem.url + && oldItem.connectionState === newItem.connectionState + && oldItem.connectionRetries === newItem.connectionRetries + && oldItem.notices === newItem.notices + } + } + + delegate: RowLayout { + Layout.fillWidth: true + spacing: 10 + width: dmRelaysListView.width + + RelayStatusIcon { + connectionState: modelData.connectionState + connectionRetries: modelData.connectionRetries + } + + Text { + text: modelData.url + font: Constants.font + color: Material.primaryTextColor + 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 + removeRelayDialog.relayType = "dm" + removeRelayDialog.open() + } + icon.source: "qrc:/icons/close.svg" + icon.width: 15 + icon.height: 15 + flat: true + } + } + } + + RowLayout { + id: preferredFooterLayout + spacing: 10 + Layout.fillWidth: true + Layout.preferredHeight: addPreferredButton.height + + Button { + id: addPreferredButton + Layout.preferredWidth: implicitWidth + 100 + icon.source: "qrc:/icons/add.svg" + text: qsTr("Add DM Relay") + onClicked: { + newDMRelaysInput.visible = true + savePreferredButton.visible = true + cancelPreferredButton.visible = true + addPreferredButton.visible = false + newDMRelaysInput.forceActiveFocus() + } + } + + TextField { + id: newDMRelaysInput + Layout.fillWidth: true + placeholderText: qsTr("Enter relay URL (ws:// or wss://)") + font: Constants.font + visible: false + text: "wss://" + onVisibleChanged: { + if (visible) { + text = "wss://" + } + } + onTextChanged: validateUrl(newDMRelaysInput) + property bool isValid: false + + Keys.onReturnPressed: { + if (newDMRelaysInput.isValid) { + savePreferredButton.clicked() + } + } + } + + Item { + width: 20 + height: 20 + visible: newDMRelaysInput.visible && newDMRelaysInput.text.trim() !== "" && newDMRelaysInput.text.trim() !== "wss://" + + Image { + id: dmRelaysIcon + anchors.fill: parent + source: "qrc:/icons/error.svg" + visible: !newDMRelaysInput.isValid + } + + ColorOverlay { + anchors.fill: parent + source: dmRelaysIcon + color: "red" + visible: !newDMRelaysInput.isValid + } + } + + Button { + id: cancelPreferredButton + visible: false + flat: true + icon.source: "qrc:/icons/cancel.svg" + onClicked: { + newDMRelaysInput.text = "" + newDMRelaysInput.visible = false + savePreferredButton.visible = false + cancelPreferredButton.visible = false + addPreferredButton.visible = true + } + } + + Button { + id: savePreferredButton + visible: false + icon.source: "qrc:/icons/save.svg" + flat: true + enabled: newDMRelaysInput.isValid + onClicked: { + if (newDMRelaysInput.text.trim() !== "") { + if (ctxRelayMgmt.addDMRelay(newDMRelaysInput.text.trim())) { + ctxRelayMgmt.connectRelay(newDMRelaysInput.text.trim()) + } + newDMRelaysInput.text = "" + newDMRelaysInput.visible = false + savePreferredButton.visible = false + cancelPreferredButton.visible = false + addPreferredButton.visible = true + } + } + } + } + } + } + + Rectangle { + Layout.fillWidth: true + height: 1 + color: Material.dividerColor + Layout.topMargin: 10 + Layout.bottomMargin: 10 + } + + ColumnLayout { + Layout.fillWidth: true + Layout.fillHeight: true + + Text { + text: qsTr("Inbox / Outbox Relays") + font: Constants.font + color: Material.primaryTextColor + Layout.alignment: Qt.AlignLeft + } + + ColumnLayout { + Layout.fillWidth: true + Layout.fillHeight: true + + ListView { + id: inboxRelayListView + Layout.fillWidth: true + Layout.fillHeight: true + clip: true + + ScrollBar.vertical: ScrollBar { + policy: ScrollBar.AsNeeded + active: true + } + + model: AutoListModel { + source: ctxRelayMgmt.generalRelays + mode: AutoListModel.ByKey + equalityTest: function (oldItem, newItem) { + return oldItem.url === newItem.url + && oldItem.connectionState === newItem.connectionState + && oldItem.isInbox === newItem.isInbox + && oldItem.isOutbox === newItem.isOutbox + && oldItem.connectionRetries === newItem.connectionRetries + && oldItem.notices === newItem.notices + } + } + + delegate: RowLayout { + Layout.fillWidth: true + spacing: 10 + width: inboxRelayListView.width + + RelayStatusIcon { + connectionState: modelData.connectionState + connectionRetries: modelData.connectionRetries + } + + Text { + text: modelData.url + font: Constants.font + color: Material.primaryTextColor + Layout.fillWidth: true + } + + CheckBox { + checked: modelData.isInbox + text: qsTr("Inbox") + enabled: false + } + + CheckBox { + checked: modelData.isOutbox + text: qsTr("Outbox") + 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 + removeRelayDialog.relayType = "general" + removeRelayDialog.open() + } + icon.source: "qrc:/icons/close.svg" + icon.width: 15 + icon.height: 15 + flat: true + } + } + } + + RowLayout { + spacing: 10 + Layout.fillWidth: true + + Button { + id: addInboxButton + Layout.preferredWidth: implicitWidth + 100 + icon.source: "qrc:/icons/add.svg" + text: qsTr("Add Relay") + visible: !newRelayInput.visible + onClicked: { + newRelayInput.visible = true + newRelayInput.forceActiveFocus() + } + } + + TextField { + id: newRelayInput + Layout.fillWidth: true + placeholderText: qsTr("Enter relay URL (ws:// or wss://)") + font: Constants.font + visible: false + text: "wss://" + onVisibleChanged: { + if (visible) { + text = "wss://" + } + } + onTextChanged: validateUrl(newRelayInput) + property bool isValid: false + + Keys.onReturnPressed: { + if (newRelayInput.isValid) { + saveInboxButton.clicked() + } + } + } + + CheckBox { + id: newInboxRelayCheckboxCheckbox + checked: true + visible: newRelayInput.visible + text: qsTr("Inbox") + } + + CheckBox { + id: newOutboxRelayCheckbox + checked: true + visible: newRelayInput.visible + text: qsTr("Outbox") + } + + Item { + width: 20 + height: 20 + visible: newRelayInput.visible && newRelayInput.text.trim() !== "" && newRelayInput.text.trim() !== "wss://" + + Image { + id: inboxRelayIcon + anchors.fill: parent + source: "qrc:/icons/error.svg" + visible: !newRelayInput.isValid + } + + ColorOverlay { + anchors.fill: parent + source: inboxRelayIcon + color: "red" + visible: !newRelayInput.isValid + } + } + + Button { + id: cancelInboxButton + visible: newRelayInput.visible + flat: true + icon.source: "qrc:/icons/cancel.svg" + onClicked: { + newRelayInput.text = "" + newRelayInput.visible = false + } + } + + Button { + id: saveInboxButton + visible: newRelayInput.visible + icon.source: "qrc:/icons/save.svg" + flat: true + enabled: newRelayInput.isValid + onClicked: { + if (newRelayInput.text.trim() !== "") { + if (ctxRelayMgmt.addGeneralRelay( + newRelayInput.text.trim(), + newInboxRelayCheckboxCheckbox.checked, + newOutboxRelayCheckbox.checked + )) { + ctxRelayMgmt.connectRelay(newRelayInput.text.trim()) + } + newRelayInput.text = "" + newRelayInput.visible = false + } + } + } + } + } + } + } + + RemoveRelayDialog { + id: removeRelayDialog + } + + function validateUrl(inputField) { + var urlRegex = /^(ws:\/\/|wss:\/\/)[\w-]+(\.[\w-]+)+([\w.,@?^=%&:/~+#-]*[\w@?^=%&/~+#-])?$/ + inputField.isValid = urlRegex.test(inputField.text.trim()) + } +} diff --git a/resources/qml/content/Dialogs/RemoveRelayDialog.ui.qml b/resources/qml/content/Dialogs/RemoveRelayDialog.ui.qml new file mode 100644 index 0000000..450770c --- /dev/null +++ b/resources/qml/content/Dialogs/RemoveRelayDialog.ui.qml @@ -0,0 +1,30 @@ +import QtQuick 2.15 +import QtQuick.Controls 2.15 +import QtQuick.Controls.Material 2.15 +import QtQuick.Layouts 1.15 + +import Futr 1.0 + +Dialog { + property string relayToRemove: "" + property string relayType + + title: qsTr("Are you sure you want to remove this relay?") + standardButtons: Dialog.Ok | Dialog.Cancel + modal: true + anchors.centerIn: parent + visible: relayToRemove !== "" + + onAccepted: { + switch (relayType) { + case "dm": + ctxRelayMgmt.removeDMRelay(relayToRemove) + case "general": + ctxRelayMgmt.removeGeneralRelay(relayToRemove) + } + } + + onRejected: { + relayToRemove = "" + } +} diff --git a/resources/qml/content/Dialogs/qmldir b/resources/qml/content/Dialogs/qmldir index 2fe3820..0f4b2fb 100644 --- a/resources/qml/content/Dialogs/qmldir +++ b/resources/qml/content/Dialogs/qmldir @@ -4,4 +4,6 @@ ImportAccountDialog 1.0 ImportAccountDialog.ui.qml ImportSuccessDialog 1.0 ImportSuccessDialog.ui.qml KeysGeneratedDialog 1.0 KeysGeneratedDialog.ui.qml LoginErrorDialog 1.0 LoginErrorDialog.ui.qml +RelayMgmtDialog 1.0 RelayMgmtDialog.ui.qml RemoveAccountDialog 1.0 RemoveAccountDialog.ui.qml +RemoveRelayDialog 1.0 RemoveRelayDialog.ui.qml diff --git a/resources/qml/content/FollowList.ui.qml b/resources/qml/content/FollowList.ui.qml index a0dfd80..5d546af 100644 --- a/resources/qml/content/FollowList.ui.qml +++ b/resources/qml/content/FollowList.ui.qml @@ -105,8 +105,10 @@ Rectangle { MouseArea { anchors.fill: parent hoverEnabled: true + onEntered: followItem.mouseHover = true onExited: followItem.mouseHover = false + onClicked: { setCurrentProfile(modelData.pubkey) openChat(modelData.pubkey) @@ -114,10 +116,12 @@ Rectangle { "profileData": currentProfile, "npub": modelData.pubkey }) - chatLoader.setSource("Chat.ui.qml", { - "profileData": currentProfile, - "npub": modelData.pubkey - }) + if (ctxRelayMgmt.dmRelays.length > 0) { + chatLoader.setSource("Chat.ui.qml", { + "profileData": currentProfile, + "npub": modelData.pubkey + }) + } } } } diff --git a/resources/qml/content/HomeScreen.ui.qml b/resources/qml/content/HomeScreen.ui.qml index 39940bc..c462a27 100644 --- a/resources/qml/content/HomeScreen.ui.qml +++ b/resources/qml/content/HomeScreen.ui.qml @@ -3,6 +3,7 @@ import QtQuick.Controls 2.15 import QtQuick.Controls.Material 2.15 import QtQuick.Layouts 1.15 +import Dialogs 1.0 import HsQML.Model 1.0 import Futr 1.0 import Profile 1.0 @@ -43,19 +44,22 @@ Item { FollowList {} - // Center column: Chat window Rectangle { width: parent.width * 0.4 - (parent.spacing * 2 / 3) height: parent.height color: Material.backgroundColor + DMRelays { + anchors.fill: parent + visible: ctxRelayMgmt.dmRelays.length == 0 + } + Loader { id: chatLoader anchors.fill: parent } } - // Right column: Profile view Rectangle { width: parent.width * 0.3 - (parent.spacing * 2 / 3) height: parent.height @@ -71,4 +75,8 @@ Item { } } } + + RelayMgmtDialog { + id: relayMgmtDialog + } } diff --git a/resources/qml/content/RelayStatusIcon.ui.qml b/resources/qml/content/RelayStatusIcon.ui.qml new file mode 100644 index 0000000..0ed6246 --- /dev/null +++ b/resources/qml/content/RelayStatusIcon.ui.qml @@ -0,0 +1,85 @@ +import QtQuick 2.15 +import QtQuick.Controls 2.15 +import QtQuick.Controls.Material 2.15 +import QtGraphicalEffects 1.15 + +Item { + id: root + width: 24 + height: 24 + + property string connectionState: "Disconnected" + property int connectionRetries: 0 + + Image { + id: connectionStateIcon + anchors.fill: parent + source: { + switch(root.connectionState) { + case "Connected": + return "qrc:/icons/wifi.svg" + case "Connecting": + return "qrc:/icons/sync.svg" + case "Disconnected": + default: + return "qrc:/icons/wifi_off.svg" + } + } + } + + ColorOverlay { + anchors.fill: parent + source: connectionStateIcon + color: { + switch(root.connectionState) { + case "Connected": + return "green" + case "Connecting": + return "orange" + case "Disconnected": + default: + return "red" + } + } + } + + Text { + id: retryCountText + anchors.right: parent.right + anchors.bottom: parent.bottom + font.pixelSize: 10 + color: Material.foreground + text: root.connectionRetries + visible: root.connectionState === "Connecting" && root.connectionRetries > 0 + + Rectangle { + anchors.fill: parent + anchors.margins: -2 + color: "red" + radius: width / 2 + z: -1 + } + } + + ToolTip.visible: connectionStateMouseArea.containsMouse + ToolTip.text: { + switch(root.connectionState) { + case "Connected": + return qsTr("Connected") + case "Connecting": + return root.connectionRetries > 0 ? + qsTr("Connecting... (Retry %1)").arg(root.connectionRetries) : + qsTr("Connecting...") + case "Disconnected": + default: + return qsTr("Disconnected") + } + } + + MouseArea { + id: connectionStateMouseArea + anchors.fill: parent + hoverEnabled: true + cursorShape: Qt.PointingHandCursor + } +} diff --git a/resources/qml/content/TopBar.ui.qml b/resources/qml/content/TopBar.ui.qml index 8ddc8d1..61f3a2a 100644 --- a/resources/qml/content/TopBar.ui.qml +++ b/resources/qml/content/TopBar.ui.qml @@ -54,6 +54,14 @@ Item { } } + MenuItem { + text: qsTr("Relay Management") + onTriggered: { + profileMenu.close() + relayMgmtDialog.open() + } + } + MenuItem { text: qsTr("Settings") onTriggered: { diff --git a/resources/qml/content/qmldir b/resources/qml/content/qmldir index c26dfcd..a38d95c 100644 --- a/resources/qml/content/qmldir +++ b/resources/qml/content/qmldir @@ -1,8 +1,10 @@ module content AccountList 1.0 AccountList.ui.qml App 1.0 App.qml +DMRelays 1.0 DMRelays.ui.qml FollowList 1.0 FollowList.ui.qml FollowListFilter 1.0 FollowListFilter.ui.qml HomeScreen 1.0 HomeScreen.ui.qml KeyMgmtScreen 1.0 KeyMgmtScreen.ui.qml +RelayStatusIcon 1.0 RelayStatusIcon.ui.qml TopBar 1.0 TopBar.ui.qml diff --git a/src/EffectfulQML.hs b/src/EffectfulQML.hs index 9a12d4c..1d268e2 100644 --- a/src/EffectfulQML.hs +++ b/src/EffectfulQML.hs @@ -4,74 +4,98 @@ module EffectfulQML where +import Control.Monad (forever, forM_, void, when) import Effectful -import Effectful.Dispatch.Dynamic (EffectHandler, interpret) -import Effectful.State.Static.Shared (State, evalState, get, put) +import Effectful.Concurrent +import Effectful.Concurrent.Async (async) +import Effectful.Concurrent.STM (TQueue, atomically, flushTQueue, newTQueueIO, readTQueue, writeTQueue) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get, gets, put) import Effectful.TH import Graphics.QML qualified as QML import Logging -import Types (AppState(..), FollowModel(..)) +import Types (AppState(..), UIReferences(..), UIUpdates(..), emptyUpdates) + +-- | Effectful QML state. data EffectfulQMLState = EffectfulQMLState { signalKey :: Maybe (QML.SignalKey (IO ())) , rootObjRef :: Maybe (QML.ObjRef ()) + , uiRefs :: UIReferences + , queue :: Maybe (TQueue UIUpdates) } + +-- | Initial effectful QML state. +initialEffectfulQMLState :: EffectfulQMLState +initialEffectfulQMLState = EffectfulQMLState Nothing Nothing initialUIRefs Nothing + + +-- | Initial UI references. +initialUIRefs :: UIReferences +initialUIRefs = UIReferences Nothing Nothing Nothing Nothing Nothing + + -- | Define the effects for QML operations. data EffectfulQML :: Effect where RunEngineLoop :: QML.EngineConfig -> QML.SignalKey (IO ()) -> QML.ObjRef () -> EffectfulQML m () CreateSignalKey :: EffectfulQML m (QML.SignalKey (IO ())) - FireSignalWith :: QML.SignalKey (IO ()) -> QML.ObjRef () -> EffectfulQML m () FireSignal :: QML.ObjRef () -> EffectfulQML m () - FireSignalOnRoot :: EffectfulQML m () - NotifyUI :: EffectfulQML m () + -- object specific signals + Notify :: UIUpdates -> EffectfulQML m () + NotifyRelayStatus :: EffectfulQML m () type instance DispatchOf EffectfulQML = Dynamic makeEffect ''EffectfulQML + -- | Handler for the QML effects. runEffectfulQML - :: (IOE :> es, Logging :> es, State AppState :> es) - => Eff (EffectfulQML : State EffectfulQMLState : es) a + :: (IOE :> es, Concurrent :> es, Logging :> es, State EffectfulQMLState :> es, State AppState :> es) + => Eff (EffectfulQML : es) a -> Eff es a -runEffectfulQML action = evalState (EffectfulQMLState Nothing Nothing) $ interpret handleEffectfulQML action - where - handleEffectfulQML - :: (IOE :> es, Logging :> es, State AppState :> es) - => EffectHandler EffectfulQML (State EffectfulQMLState : es) - handleEffectfulQML _ = \case - RunEngineLoop config changeKey ctx -> do - put $ EffectfulQMLState (Just changeKey) (Just ctx) - liftIO $ QML.runEngineLoop config +runEffectfulQML = interpret $ \_ -> \case + RunEngineLoop config changeKey ctx -> do + q <- newTQueueIO + put $ EffectfulQMLState (Just changeKey) (Just ctx) initialUIRefs (Just q) + void $ async $ forever $ do + uiUpdates <- atomically $ readTQueue q + moreUpdates <- atomically $ flushTQueue q + let combinedUpdates = uiUpdates <> mconcat moreUpdates + + refs <- gets uiRefs + + when (profilesChanged combinedUpdates) $ forM_ (profileObjRef refs) (liftIO . QML.fireSignal changeKey) + when (followsChanged combinedUpdates) $ forM_ (followsObjRef refs) (liftIO . QML.fireSignal changeKey) + when (chatsChanged combinedUpdates) $ forM_ (chatObjRef refs) (liftIO . QML.fireSignal changeKey) + when (dmRelaysChanged combinedUpdates) $ forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal changeKey) + when (generalRelaysChanged combinedUpdates) $ forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal changeKey) - CreateSignalKey -> liftIO $ QML.newSignalKey + threadDelay 100000 -- max 10 UI updates per second - FireSignalWith changeKey obj -> liftIO $ QML.fireSignal changeKey obj + liftIO $ QML.runEngineLoop config + + CreateSignalKey -> liftIO $ QML.newSignalKey - FireSignal obj -> do + FireSignal obj -> do st <- get case signalKey st of Just key -> liftIO $ QML.fireSignal key obj Nothing -> logError "No signal key available" - FireSignalOnRoot -> do + NotifyRelayStatus -> do st <- get - case (rootObjRef st, signalKey st) of - (Just rootObj', Just changeKey') -> do - logDebug "Firing signal on root" - liftIO $ QML.fireSignal changeKey' rootObj' - _ -> logWarning "No rootObjRef or signalKey" + case queue st of + Just q -> do + let updates = emptyUpdates { dmRelaysChanged = True, generalRelaysChanged = True } + atomically $ writeTQueue q updates + Nothing -> logError "No queue available" - NotifyUI -> do + Notify u -> do st <- get - case signalKey st of - Just key -> do - let notifyObjRef = maybe (pure ()) (liftIO . QML.fireSignal key) - st' <- get @AppState - notifyObjRef (objRef $ follows st') - notifyObjRef (profileObjRef st') - notifyObjRef (chatObjRef st') - Nothing -> logWarning "No signal key available for NotifyUI" + case queue st of + Just q -> atomically $ writeTQueue q u + Nothing -> logError "No queue available" diff --git a/src/Futr.hs b/src/Futr.hs index 3c91ec6..b6a4e3a 100644 --- a/src/Futr.hs +++ b/src/Futr.hs @@ -4,7 +4,7 @@ module Futr where -import Control.Monad (forM, forM_, void, unless, when) +import Control.Monad (forM, forM_, unless, void, when) import Data.Aeson (ToJSON, pairs, toEncoding, (.=)) import Data.Maybe (catMaybes, listToMaybe) import Data.Map.Strict qualified as Map @@ -13,9 +13,10 @@ import Data.Text (Text, isPrefixOf) import Data.Typeable (Typeable) import Effectful import Effectful.Concurrent -import Effectful.Concurrent.Async (Async, async, waitAny) +import Effectful.Concurrent.Async (async) +import Effectful.Concurrent.STM (atomically, readTQueue) import Effectful.Dispatch.Dynamic (interpret) -import Effectful.State.Static.Shared (State, get, gets, modify) +import Effectful.State.Static.Shared (State, get, gets, modify, put) import Effectful.TH import EffectfulQML import GHC.Generics (Generic) @@ -28,13 +29,14 @@ import Nostr.Bech32 import Nostr.Event (createFollowList, createRumor) import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO, secKeyToKeyPair) import Nostr.GiftWrap +import Nostr.Publisher import Nostr.RelayPool import Nostr.Subscription -import Nostr.Types ( RelayURI, Relay(..), Tag(..), - followListFilter, giftWrapFilter, metadataFilter, - relayName, relayURIToText) +import Nostr.Types ( Relay(..), RelayURI, Tag(..) + , getUri, metadataFilter ) import Nostr.Util import Presentation.KeyMgmt qualified as PKeyMgmt +import Presentation.RelayMgmt qualified as PRelayMgmt import Types -- | Signal key class for LoginStatusChanged. @@ -60,8 +62,8 @@ instance ToJSON SearchResult where -- | Futr Effects. data Futr :: Effect where - Login :: ObjRef () -> Text -> Futr m Bool - Search :: ObjRef () -> Text -> Futr m SearchResult + Login :: ObjRef () -> Text -> Futr m () + Search :: ObjRef () -> Text -> Futr m () SetCurrentProfile :: Text -> Futr m () FollowProfile :: Text -> Futr m () UnfollowProfile :: Text -> Futr m () @@ -81,11 +83,14 @@ makeEffect ''Futr type FutrEff es = ( State AppState :> es , PKeyMgmt.KeyMgmt :> es , PKeyMgmt.KeyMgmtUI :> es + , PRelayMgmt.RelayMgmtUI :> es , Nostr :> es , RelayPool :> es , Subscription :> es + , Publisher :> es , State PKeyMgmt.KeyMgmtState :> es , State RelayPoolState :> es + , State EffectfulQMLState :> es , GiftWrap :> es , EffectfulQML :> es , Logging :> es @@ -101,58 +106,31 @@ runFutr = interpret $ \_ -> \case Login obj input -> do kst <- get @PKeyMgmt.KeyMgmtState case Map.lookup (PKeyMgmt.AccountId input) (PKeyMgmt.accountMap kst) of - Just a -> do - success <- loginWithAccount obj a - return success - Nothing -> return False + Just a -> loginWithAccount obj a + Nothing -> liftIO $ QML.fireSignal (Proxy :: Proxy LoginStatusChanged) obj False "Account not found" Search _ input -> do st <- get @AppState let myPubKey = keyPairToPubKeyXO <$> keyPair st - case input of - _ | "nprofile" `isPrefixOf` input || "npub" `isPrefixOf` input -> do - case parseNprofileOrNpub input of - Just (pubkey', maybeRelay) -> do - case myPubKey of - Just myKey | myKey == pubkey' -> do - return $ ProfileResult (pubKeyXOToBech32 pubkey') (relayURIToText <$> maybeRelay) - - _ -> do - let userFollows = maybe [] (flip (Map.findWithDefault []) (followList $ follows st)) myPubKey - if any (\(Follow pk _ _) -> pk == pubkey') userFollows - then do - return $ ProfileResult (pubKeyXOToBech32 pubkey') (relayURIToText <$> maybeRelay) - else do - case maybeRelay of - Just relay' -> return $ ProfileResult (pubKeyXOToBech32 pubkey') (Just $ relayURIToText relay') - Nothing -> do - relays' <- gets @RelayPoolState relays - let relaysToSearch = Map.keys relays' - forM_ relaysToSearch $ \relay' -> do - void $ async $ do - maybeSubInfo <- startSubscription relay' [metadataFilter [pubkey']] - case maybeSubInfo of - Just (subId, queue) -> do - handleResponsesUntilEOSE relay' queue - stopSubscription subId - Nothing -> - logWarning $ "Failed to start search subscription for relay: " <> relayURIToText relay' - - return $ ProfileResult (pubKeyXOToBech32 pubkey') Nothing - - Nothing -> return NoResult - - _ -> return NoResult + if not ("nprofile" `isPrefixOf` input || "npub" `isPrefixOf` input) + then return () + else case parseNprofileOrNpub input of + Nothing -> return () + Just (pubkey', maybeRelay) + | Just pubkey' == myPubKey -> + return () + | otherwise -> do + let userFollows = maybe [] (flip (Map.findWithDefault []) (follows st)) myPubKey + if any (\(Follow pk _ _) -> pk == pubkey') userFollows + then return () + else searchInRelays pubkey' maybeRelay SetCurrentProfile npub' -> do case bech32ToPubKeyXO npub' of Just pk -> do modify @AppState $ \st -> st { currentProfile = Just pk } - obj <- gets @AppState profileObjRef - case obj of - Just obj' -> fireSignal obj' - Nothing -> return () + notify $ emptyUpdates { profilesChanged = True } Nothing -> do logError $ "Invalid npub, cannot set current profile: " <> npub' return () @@ -162,12 +140,12 @@ runFutr = interpret $ \_ -> \case st <- get @AppState case keyPairToPubKeyXO <$> keyPair st of Just userPK -> do - let currentFollows = Map.findWithDefault [] userPK (followList $ follows st) + let currentFollows = Map.findWithDefault [] userPK (follows st) unless (any (\follow -> pubkey follow == pubKeyXO) currentFollows) $ do let newFollow = Follow pubKeyXO Nothing Nothing let newFollows = newFollow : currentFollows - modify $ \st' -> st' { follows = (follows st') { followList = Map.insert userPK newFollows (followList $ follows st') } } - notifyUI + modify $ \st' -> st' { follows = Map.insert userPK newFollows (follows st') } + notify $ emptyUpdates { followsChanged = True } sendFollowListEvent Nothing -> return () @@ -177,10 +155,10 @@ runFutr = interpret $ \_ -> \case let userPubKey = keyPairToPubKeyXO <$> keyPair st case userPubKey of Just userPK -> do - let currentFollows = Map.findWithDefault [] userPK (followList $ follows st) + let currentFollows = Map.findWithDefault [] userPK (follows st) let newFollows = filter (\follow -> pubkey follow /= pubKeyXO) currentFollows - modify $ \st' -> st' { follows = (follows st') { followList = Map.insert userPK newFollows (followList $ follows st') } } - notifyUI + modify $ \st' -> st' { follows = Map.insert userPK newFollows (follows st') } + notify $ emptyUpdates { followsChanged = True } sendFollowListEvent Nothing -> return () @@ -192,7 +170,7 @@ runFutr = interpret $ \_ -> \case _ -> return () modify $ \st' -> st' { currentChatRecipient = (Just [pubKeyXO], Nothing) } - notifyUI + notify $ emptyUpdates { chatsChanged = True } SendMessage input -> do st <- get @AppState @@ -214,8 +192,8 @@ runFutr = interpret $ \_ -> \case Nothing -> logError "Failed to create seal" >> return Nothing let validGiftWraps = catMaybes giftWraps - relays' <- gets @RelayPoolState relays - mapM_ (\gw -> sendEvent gw (Map.keys relays')) validGiftWraps + forM_ validGiftWraps $ \gw -> publishGiftWrap gw senderPubKeyXO + (Nothing, _) -> logError "No key pair found" (_, (Nothing, _)) -> logError "No current chat recipient" @@ -223,17 +201,14 @@ runFutr = interpret $ \_ -> \case modify @AppState $ \st -> st { keyPair = Nothing , currentScreen = KeyMgmt - , follows = FollowModel Map.empty (objRef $ follows st) + , follows = Map.empty , profiles = Map.empty - , confirmations = Map.empty } - relays' <- gets @RelayPoolState relays - mapM_ disconnect (Map.keys relays') + conns <- gets @RelayPoolState activeConnections + mapM_ disconnect (Map.keys conns) - modify @RelayPoolState $ \st -> st - { relays = Map.empty - } + put initialRelayPoolState fireSignal obj logInfo "User logged out successfully" @@ -243,102 +218,90 @@ runFutr = interpret $ \_ -> \case parseNprofileOrNpub :: Text -> Maybe (PubKeyXO, Maybe RelayURI) parseNprofileOrNpub input = case bech32ToPubKeyXO input of - Just pubkey' -> Just (pubkey', Nothing) -- For npub + Just pubkey' -> Just (pubkey', Nothing) -- for npub Nothing -> case nprofileToPubKeyXO input of - Just (pubkey', relays') -> Just (pubkey', listToMaybe relays') -- For nprofile + Just (pubkey', relays') -> Just (pubkey', listToMaybe relays') -- for nprofile Nothing -> Nothing -- | Login with an account. -loginWithAccount :: FutrEff es => ObjRef () -> PKeyMgmt.Account -> Eff es Bool +loginWithAccount :: FutrEff es => ObjRef () -> PKeyMgmt.Account -> Eff es () loginWithAccount obj a = do - let kp = secKeyToKeyPair $ PKeyMgmt.nsec a - let xo = keyPairToPubKeyXO kp - let rs = PKeyMgmt.relays a - - -- add all relays to the relay pool - mapM_ addRelay rs - - -- For each relay, asynchronously connect and handle subscriptions - connectionResults <- forM rs $ \relay' -> async $ do - isConnected <- connect relay' - - if isConnected - then do - logDebug $ "Connected to relay: " <> relayName relay' - modify @AppState $ \st -> st { keyPair = Just kp, currentScreen = Home } - fireSignal obj - liftIO $ QML.fireSignal (Proxy :: Proxy LoginStatusChanged) obj True "" + let (rs, t) = PKeyMgmt.accountRelays a + + modify @AppState $ \s -> s { keyPair = Just (secKeyToKeyPair $ PKeyMgmt.accountSecKey a) } + importGeneralRelays (PKeyMgmt.accountPubKeyXO a) rs t + + forM_ rs $ \relay' -> void $ async $ connect $ getUri relay' + + void $ async $ do + threadDelay 100000 -- 100ms miinum delay to wait for connections to establish - -- Initial subscription (until EOSE) - let initialFilters = - [ followListFilter [ xo ] - , metadataFilter [ xo ] - ] - - logDebug $ "Starting initial subscription for relay: " <> relayName relay' - - maybeSubInfo <- startSubscription (uri relay') initialFilters - case maybeSubInfo of - Nothing -> logWarning $ "Failed to start initial subscription for relay: " <> relayName relay' - Just (subId', queue) -> do - void $ async $ do - handleResponsesUntilEOSE (uri relay') queue - stopSubscription subId' - fireSignal obj - - -- Start the main subscription after EOSE - st <- get @AppState - let followedPubKeys = concatMap (\(_, follows') -> map (\(Follow pk _ _) -> pk) follows') $ Map.toList $ followList $ follows st - let filters = - [ followListFilter (xo : followedPubKeys) - , metadataFilter (xo : followedPubKeys) - , giftWrapFilter xo - ] - - maybeSubInfo' <- startSubscription (uri relay') filters - case maybeSubInfo' of - Nothing -> logWarning $ "Failed to start main subscription for relay: " <> (relayURIToText $ uri relay') - Just (_, queue') -> do - handleResponsesUntilClosed (uri relay') queue' - return True - else return False - - atLeastOneConnected <- waitForFirstTrueOrAllFalse connectionResults - - when (not atLeastOneConnected) $ do - liftIO $ QML.fireSignal (Proxy :: Proxy LoginStatusChanged) obj False "Failed to connect to any relay" - - return atLeastOneConnected - where - waitForFirstTrueOrAllFalse :: FutrEff es => [Async Bool] -> Eff es Bool - waitForFirstTrueOrAllFalse [] = return False - waitForFirstTrueOrAllFalse asyncs = do - (completed, result) <- waitAny asyncs - if result - then return True - else do - let remainingAsyncs = filter (/= completed) asyncs - waitForFirstTrueOrAllFalse remainingAsyncs + atLeastOneConnected <- awaitAtLeastOneConnected + -- Update UI state after connections are established + when atLeastOneConnected $ do + modify @AppState $ \s -> s { currentScreen = Home } + fireSignal obj + + -- Fire final status + if not atLeastOneConnected + then liftIO $ QML.fireSignal (Proxy :: Proxy LoginStatusChanged) obj False "Failed to connect to any relay" + else liftIO $ QML.fireSignal (Proxy :: Proxy LoginStatusChanged) obj True "" -- | Send a follow list event. sendFollowListEvent :: FutrEff es => Eff es () sendFollowListEvent = do - st <- get @AppState - case keyPair st of - Just kp -> do - currentTime <- getCurrentTime - let userPK = keyPairToPubKeyXO kp - let followList' = Map.findWithDefault [] userPK (followList $ follows st) - let followTuples = map (\(Follow pk _ petName') -> (pk, petName')) followList' - let event = createFollowList followTuples userPK currentTime - signedEvent <- signEvent event kp - case signedEvent of - Just signedEvent' -> do - relays' <- gets @RelayPoolState relays - sendEvent signedEvent' (Map.keys relays') - Nothing -> do - logError "Failed to sign follow list event" - return () - Nothing -> return () + st <- get @AppState + case keyPair st of + Nothing -> logError "No keypair found" + Just kp -> do + currentTime <- getCurrentTime + let userPK = keyPairToPubKeyXO kp + followList' = Map.findWithDefault [] userPK (follows st) + followTuples = map (\(Follow pk _ petName') -> (pk, petName')) followList' + event = createFollowList followTuples userPK currentTime + signedEvent <- signEvent event kp + case signedEvent of + Just signedEvent' -> publishToOutbox signedEvent' + Nothing -> do + logError "Failed to sign follow list event" + return () + + +-- | 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 $ \r -> do + when (isInboxCapable r) $ do + let relayUri' = getUri r + 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 + 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 + + +isInboxCapable :: Relay -> Bool +isInboxCapable (InboxRelay _) = True +isInboxCapable (InboxOutboxRelay _) = True +isInboxCapable _ = False diff --git a/src/Main.hs b/src/Main.hs index b2a1b03..4209c2c 100755 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,23 +3,27 @@ module Main where import Effectful import Effectful.Concurrent (runConcurrent) import Effectful.FileSystem (runFileSystem) -import Effectful.State.Static.Shared (evalState) -import EffectfulQML +import Effectful.State.Static.Shared (State, evalState) import Graphics.QML qualified as QML import System.Environment (setEnv) +import EffectfulQML import Futr qualified as Futr import Logging (runLoggingStdout) import Nostr import Nostr.GiftWrap (runGiftWrap) +import Nostr.Publisher (runPublisher) +import Nostr.RelayConnection (runRelayConnection) import Nostr.RelayPool (runRelayPool) import Nostr.Subscription (runSubscription) -import Nostr.WebSocket (runWebSocket) import Nostr.Util (runUtil) import Presentation.KeyMgmt qualified as KeyMgmt +import Presentation.RelayMgmt qualified as RelayMgmtUI +import RelayMgmt (runRelayMgmt) import UI qualified as UI import Types +-- | Main function for the app. main :: IO () main = do let path = "qrc:/qml/main.qml" @@ -34,20 +38,27 @@ main = do runEff . runLoggingStdout - . evalState Types.initialState + . runConcurrent + -- state related + . withInitialState + -- app related + . evalState initialEffectfulQMLState . runEffectfulQML . runFileSystem . runUtil - . runConcurrent - . evalState KeyMgmt.initialState - . evalState Types.initialRelayPoolState + -- nostr related . runNostr . KeyMgmt.runKeyMgmt - . KeyMgmt.runKeyMgmtUI . runGiftWrap - . runWebSocket 3 -- max 3 retries - . runRelayPool + . runRelayConnection + . runPublisher + . runRelayMgmt . runSubscription + . runRelayPool + -- presentation related + . KeyMgmt.runKeyMgmtUI + . RelayMgmtUI.runRelayMgmtUI + -- run futr . Futr.runFutr . UI.runUI $ do @@ -62,3 +73,16 @@ main = do } runEngineLoop config changeKey ctx + + +-- | Initialize the state for the app. +withInitialState + :: Eff ( State RelayPoolState + : State KeyMgmt.KeyMgmtState + : State AppState + : es) a + -> Eff es a +withInitialState + = evalState Types.initialState + . evalState KeyMgmt.initialState + . evalState Types.initialRelayPoolState diff --git a/src/Nostr/Bech32.hs b/src/Nostr/Bech32.hs index b29cca2..5334429 100644 --- a/src/Nostr/Bech32.hs +++ b/src/Nostr/Bech32.hs @@ -26,7 +26,7 @@ import Data.Word (Word8) import Text.Read (readMaybe) import Nostr.Keys (SecKey, PubKeyXO, importPubKeyXO, exportPubKeyXO, importSecKey, exportSecKey) -import Nostr.Types (Event(..), EventId(..), Kind, RelayURI(..), relayURIToText) +import Nostr.Types (Event(..), EventId(..), Kind, RelayURI) -- | Bech32 encoding for SecKey @@ -78,7 +78,7 @@ eventToNevent event relayURI' = toBech32 "nevent" $ encodeTLV tlvData , (3, BSS.toShort $ encodeUtf8 $ T.pack $ show $ kind event) ] tlvData = case relayURI' of - Just r -> (1, BSS.toShort $ encodeUtf8 $ relayURIToText r) : baseTLV + Just r -> (1, BSS.toShort $ encodeUtf8 r) : baseTLV Nothing -> baseTLV @@ -96,7 +96,7 @@ neventToEvent txt = do -- | Convert a PubKeyXO and list of relays to nprofile bech32 encoding pubKeyXOToNprofile :: PubKeyXO -> [RelayURI] -> T.Text pubKeyXOToNprofile pubKey' relays = toBech32 "nprofile" $ encodeTLV $ - (0, BSS.toShort $ exportPubKeyXO pubKey') : map (\r -> (1, BSS.toShort $ encodeUtf8 $ relayURIToText r)) relays + (0, BSS.toShort $ exportPubKeyXO pubKey') : map (\r -> (1, BSS.toShort $ encodeUtf8 r)) relays -- | Decode nprofile bech32 encoding to PubKeyXO and relays @@ -109,14 +109,14 @@ nprofileToPubKeyXO txt = do Nothing -> Nothing let relays = mapMaybe (\(t, v) -> if t == 1 - then pure $ RelayURI (decodeUtf8 $ BSS.fromShort v) + then pure $ decodeUtf8 $ BSS.fromShort v else Nothing) tlvs return (pubKey', relays) -- | Convert a relay URI to nrelay bech32 encoding relayToNrelay :: RelayURI -> T.Text -relayToNrelay relay = toBech32 "nrelay" $ encodeTLV [(0, BSS.toShort $ encodeUtf8 $ relayURIToText relay)] +relayToNrelay relay = toBech32 "nrelay" $ encodeTLV [(0, BSS.toShort $ encodeUtf8 relay)] -- | Decode nrelay bech32 encoding to RelayURI @@ -125,7 +125,7 @@ nrelayToRelay txt = do bs <- fromBech32 "nrelay" txt let tlvs = decodeTLV bs relayText <- lookup 0 tlvs >>= (Just . decodeUtf8 . BSS.fromShort) - pure $ RelayURI relayText + pure relayText -- | Convert from bech32 to ByteString diff --git a/src/Nostr/Event.hs b/src/Nostr/Event.hs index 82bc2aa..8cce4e4 100755 --- a/src/Nostr/Event.hs +++ b/src/Nostr/Event.hs @@ -17,6 +17,7 @@ import Nostr.Types import Nostr.Encryption (decrypt, getConversationKey, encrypt) import Data.Time.Clock.POSIX (getCurrentTime, utcTimeToPOSIXSeconds) import Crypto.Random (getRandomBytes) +import System.Random (randomRIO) -- | Sign an event. @@ -102,7 +103,7 @@ createFollowList contacts xo t = { pubKey' = xo , createdAt' = t , kind' = FollowList - , tags' = map (\c -> PTag (fst c) (Just (RelayURI "")) (snd c)) contacts + , tags' = map (\c -> PTag (fst c) (Just "") (snd c)) contacts , content' = "" } @@ -121,13 +122,36 @@ createEventDeletion eids reason xo t = toDelete = map (\eid -> ETag eid Nothing Nothing) eids +createRelayListMetadataEvent :: [Relay] -> PubKeyXO -> Int -> UnsignedEvent +createRelayListMetadataEvent relays xo t = + UnsignedEvent + { pubKey' = xo + , createdAt' = t + , kind' = RelayListMetadata + , tags' = map (\r -> RelayTag r) relays + , content' = "" + } + + +createPreferredDMRelaysEvent :: [RelayURI] -> PubKeyXO -> Int -> UnsignedEvent +createPreferredDMRelaysEvent urls xo t = + UnsignedEvent + { pubKey' = xo + , createdAt' = t + , kind' = PreferredDMRelays + , tags' = map (\url -> RelayTag $ InboxOutboxRelay url) urls + , content' = "" + } + + createCanonicalAuthentication :: RelayURI -> Text -> PubKeyXO -> Int -> UnsignedEvent -createCanonicalAuthentication relayURI' challenge xo t = +createCanonicalAuthentication r challenge xo t = UnsignedEvent { pubKey' = xo , createdAt' = t , kind' = CanonicalAuthentication - , tags' = [RelayTag relayURI', ChallengeTag challenge] + -- force the relay to be a InboxOutboxRelay for the purpose of authentication + , tags' = [RelayTag $ InboxOutboxRelay r, ChallengeTag challenge] , content' = "" } @@ -165,9 +189,11 @@ createSeal rumor kp pk = do Left _ -> return Nothing Right sealContent -> do currentTime <- getCurrentTime + randomOffset <- randomRIO (0, 2 * 24 * 60 * 60 :: Int) + let timestamp = floor (utcTimeToPOSIXSeconds currentTime) - randomOffset let sealEvent = UnsignedEvent { pubKey' = keyPairToPubKeyXO kp - , createdAt' = floor $ utcTimeToPOSIXSeconds currentTime + , createdAt' = timestamp , kind' = Seal , tags' = [] , content' = sealContent diff --git a/src/Nostr/Publisher.hs b/src/Nostr/Publisher.hs new file mode 100644 index 0000000..c3fe3a8 --- /dev/null +++ b/src/Nostr/Publisher.hs @@ -0,0 +1,195 @@ +module Nostr.Publisher where + +import Control.Monad (forM_, when) +import Data.List (nub, partition) +import Data.Map.Strict qualified as Map +import Data.Text (Text, pack) +import Effectful +import Effectful.Concurrent (Concurrent, threadDelay) +import Effectful.Concurrent.Async (async) +import Effectful.Concurrent.STM (atomically, writeTChan) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get, gets, modify) +import Effectful.TH +--import Network.URI (URI(..), parseURI, uriAuthority, uriPort, uriRegName, uriScheme) + +import EffectfulQML +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.Util +import Types ( AppState(..), ConnectionState(..), Follow(..) + , PublishStatus(..), RelayData(..), RelayPoolState(..) ) + + +-- | Result of a publish operation +data PublishResult + = PublishSuccess [RelayURI] [RelayURI] + | PublishFailure Text + deriving (Show) + + +-- | Publisher effects +data Publisher :: Effect where + Broadcast :: Event -> Publisher m () + PublishToOutbox :: Event -> Publisher m () + PublishToRelay :: Event -> RelayURI -> Publisher m () + PublishGiftWrap :: Event -> PubKeyXO -> Publisher m () + GetPublishResult :: EventId -> Publisher m PublishResult + +type instance DispatchOf Publisher = Dynamic + +makeEffect ''Publisher + + +-- | Publisher effect handlers +type PublisherEff es = + ( State AppState :> es + , State RelayPoolState :> es + , RelayConnection :> es + , EffectfulQML :> es + , Concurrent :> es + , Logging :> es + , Util :> es + ) + + +-- | Run a publisher +runPublisher + :: PublisherEff es + => 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) + + kp <- getKeyPair + let pk = keyPairToPubKeyXO kp + st <- get @AppState + let follows' = Map.findWithDefault [] pk (follows st) + let followPks = map pubkey follows' + otherGeneralRelays <- gets @RelayPoolState (concatMap (fst . snd) . + filter (\(k,_) -> k `elem` followPks && k /= pubKey event) . Map.toList . generalRelays) + + let allTargetRelays = nub $ + map getUri allDMRelays ++ + map getUri myOutboxCapable ++ + map getUri otherGeneralRelays + + modify $ \st' -> st' + { publishStatus = Map.insert + (eventId event) + (Map.fromList [(relay, Publishing) | relay <- allTargetRelays]) + (publishStatus st') + } + + existingConnections <- getConnectedRelays + let (existingRelays, newRelays) = partition (`elem` existingConnections) allTargetRelays + + forM_ existingRelays $ \r -> writeToChannel event r + + forM_ newRelays $ \r -> async $ do + connected <- connectRelay r + when connected $ do + threadDelay 100000 -- wait 100ms for authentication + writeToChannel event r + disconnectRelay r + + 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 + + modify $ \st -> st + { publishStatus = Map.insert + (eventId event) + (Map.fromList [(relay, Publishing) | relay <- outboxCapableURIs]) + (publishStatus st) + } + + forM_ outboxCapableURIs $ \r -> writeToChannel event r + + PublishToRelay event' relayUri' -> do + modify $ \st -> st + { publishStatus = Map.adjust + (\existingMap -> Map.insert relayUri' Publishing existingMap) + (eventId event') + (publishStatus st) + } + 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) + + if null dmRelayList || null recipientDMRelays + then pure () + else do + let allRelayURIs = nub $ + map getUri (fst dmRelayList) ++ + map getUri (fst 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 + when connected $ do + threadDelay 100000 -- wait 100ms for authentication + writeToChannel event' r + disconnectRelay r + + GetPublishResult eventId' -> do + st <- get @RelayPoolState + let states = Map.findWithDefault Map.empty eventId' (publishStatus st) + if null states + then return $ PublishFailure "No relays found to publish to" + else do + let (successRelays, failureRelays) = Map.partitionWithKey (\_ v -> v == Success) states + return $ PublishSuccess (Map.keys successRelays) (Map.keys failureRelays) + + +-- | Write an event to a channel +writeToChannel :: PublisherEff es => Event -> RelayURI -> Eff es () +writeToChannel e r = do + st <- get @RelayPoolState + case Map.lookup r (activeConnections st) of + Just rd -> do + atomically $ writeTChan (requestChannel rd) (SendEvent e) + modify $ \st' -> st' { publishStatus = Map.adjust (Map.insert r WaitingForConfirmation) (eventId e) (publishStatus st') } + Nothing -> do + modify $ \st' -> st' { publishStatus = Map.adjust (Map.insert r (Failure "No channel found")) (eventId e) (publishStatus st') } + + +-- | Get the connected relays +getConnectedRelays :: PublisherEff es => Eff es [RelayURI] +getConnectedRelays = do + st <- get @RelayPoolState + 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 new file mode 100644 index 0000000..bdcb85e --- /dev/null +++ b/src/Nostr/RelayConnection.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE BlockArguments #-} + +module Nostr.RelayConnection where + +import Control.Exception (SomeException, try) +import Control.Monad (void, when) +import Data.Aeson (eitherDecode, encode) +import Data.ByteString.Lazy qualified as BSL +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Effectful +import Effectful.Concurrent (Concurrent, forkIO) +import Effectful.Concurrent.Async (async, waitAnyCancel) +import Effectful.Concurrent.STM ( TChan, TMVar, atomically, newTChanIO, newTQueueIO + , newEmptyTMVarIO, putTMVar, readTChan + , takeTMVar, writeTChan, writeTQueue ) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get, gets, modify) +import Effectful.TH +import Network.WebSockets qualified as WS +import Wuss qualified as Wuss + +import EffectfulQML +import Logging +import Nostr +import Nostr.Event (createCanonicalAuthentication) +import Nostr.Keys (keyPairToPubKeyXO) +--import Nostr.Subscription +import Nostr.Types ( Event(..), RelayURI + , Request(..), Response(..), SubscriptionId ) +import Nostr.Types qualified as NT +import Nostr.Util +import Types ( AppState(..), ConnectionError(..), ConnectionState(..) + , PublishStatus(..),RelayPoolState(..), RelayData(..) + , SubscriptionDetails(..), SubscriptionEvent(..), UIUpdates(..), emptyUpdates ) + + +-- | Reason for disconnecting from a relay. +data DisconnectReason = UserInitiated | ConnectionFailure + deriving (Show, Eq) + + +-- | Effect for handling RelayPool operations. +data RelayConnection :: Effect where + ConnectRelay :: RelayURI -> RelayConnection m Bool + DisconnectRelay :: RelayURI -> RelayConnection m () + + +type instance DispatchOf RelayConnection = Dynamic + + +makeEffect ''RelayConnection + + +-- | RelayConnectionEff +type RelayConnectionEff es = + ( State AppState :> es + , State RelayPoolState :> es + , Nostr :> es + , EffectfulQML :> es + , Concurrent :> es + , Logging :> es + , Util :> es + , IOE :> es + ) + + +-- | Handler for relay pool effects. +runRelayConnection + :: RelayConnectionEff es + => Eff (RelayConnection : es) a + -> Eff es a +runRelayConnection = interpret $ \_ -> \case + ConnectRelay r -> do + conns <- gets @RelayPoolState activeConnections + if Map.member r conns + then do + let connState = connectionState <$> Map.lookup r conns + case connState of + Just Connected -> do + logDebug $ "Already connected to " <> r + return True + Just Connecting -> do + logDebug $ "Connection already in progress for " <> r + return False + Just Disconnected -> do + -- Try to reconnect + chan <- newTChanIO + connectWithRetry r 5 chan + Nothing -> do + logWarning $ "No connection state found for relay: " <> r + return False + else do + chan <- newTChanIO + let rd = RelayData + { connectionState = Connecting + , requestChannel = chan + , activeSubscriptions = Map.empty + , lastError = Nothing + , connectionAttempts = 0 + , notices = [] + , authenticated = False + } + modify @RelayPoolState $ \st -> + st { activeConnections = Map.insert r rd (activeConnections st) } + connectWithRetry r 5 chan + + DisconnectRelay r -> do + st <- get @RelayPoolState + case Map.lookup r (activeConnections st) of + Just rd -> do + void $ atomically $ writeTChan (requestChannel rd) NT.Disconnect + modify @RelayPoolState $ \st' -> + st' { activeConnections = Map.delete r (activeConnections st') } + Nothing -> return () + + +-- | Connect with retry. +connectWithRetry :: RelayConnectionEff es => RelayURI -> Int -> TChan Request -> Eff es Bool +connectWithRetry r maxRetries requestChan = do + st <- get @RelayPoolState + + let attempts = maybe 0 connectionAttempts $ Map.lookup r (activeConnections st) + if attempts >= maxRetries + then do + modify @RelayPoolState $ \st' -> + st' { activeConnections = Map.adjust + (\d -> d { connectionState = Disconnected + , lastError = Just MaxRetriesReached + }) + r + (activeConnections st') + } + return False + 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 "/" + + void $ forkIO $ withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> do + let runClient = nostrClient connectionMVar r requestChan runE + result <- try @SomeException $ connectAction runClient + case result of + Right _ -> return () + Left e -> runE $ do + atomically $ putTMVar connectionMVar False + logError $ "Connection error: " <> T.pack (show e) + st' <- get @RelayPoolState + when (Map.member r (activeConnections st')) $ + modify @RelayPoolState $ \s -> + s { activeConnections = Map.adjust + (\d -> d { connectionState = Disconnected + , lastError = Just $ ConnectionFailed $ T.pack (show e) + }) + r + (activeConnections s) + } + + result <- atomically $ takeTMVar connectionMVar + return result + + +-- | Nostr client for relay connections. +nostrClient :: RelayConnectionEff es => TMVar Bool -> RelayURI -> TChan Request -> (forall a. Eff es a -> IO a) -> WS.ClientApp () +nostrClient connectionMVar r requestChan runE conn = runE $ do + logDebug $ "Connected to " <> r + void $ atomically $ putTMVar connectionMVar True + modify @RelayPoolState $ \st -> + st { activeConnections = Map.adjust (\d -> d { connectionState = Connected }) r (activeConnections st) } + notifyRelayStatus + updateQueue <- newTQueueIO + + -- Start receive and send loops as async tasks + receiveThread <- async $ receiveLoop updateQueue + sendThread <- async $ sendLoop + + -- Wait for either thread to finish + void $ waitAnyCancel [receiveThread, sendThread] + modify @RelayPoolState $ \st -> + st { activeConnections = Map.adjust (\d -> d { connectionState = Disconnected }) r (activeConnections st) } + notifyRelayStatus + where + receiveLoop q = do + msg <- liftIO (try (WS.receiveData conn) :: IO (Either SomeException BSL.ByteString)) + case msg of + Left ex -> do + logError $ "Error receiving data from " <> r <> ": " <> T.pack (show ex) + return () -- Exit the loop on error + Right msg' -> case eitherDecode msg' of + Right response -> do + updates <- handleResponse r response + atomically $ writeTQueue q updates + receiveLoop q + Left err -> do + logError $ "Could not decode server response from " <> r <> ": " <> T.pack err + receiveLoop q + + sendLoop = do + msg <- atomically $ readTChan requestChan + case msg of + NT.Disconnect -> do + liftIO $ WS.sendClose conn (T.pack "Bye!") + return () -- Exit the loop after disconnect + _ -> do + result <- liftIO $ try @SomeException $ WS.sendTextData conn $ encode msg + case result of + Left ex -> do + logError $ "Error sending data to " <> r <> ": " <> T.pack (show ex) + return () -- Exit the loop on error + Right _ -> sendLoop + + +-- | Handle responses. +handleResponse :: RelayConnectionEff es => RelayURI -> Response -> Eff es UIUpdates +handleResponse relayURI' r = case r of + EventReceived subId' event' -> do + recordLatestCreatedAt relayURI' 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 + (\subDetails -> if createdAt e > newestCreatedAt subDetails + then subDetails { newestCreatedAt = createdAt e } + else subDetails) + subId' + (activeSubscriptions rd) + }) + r' + (activeConnections st) + } + + Eose subId' -> do + enqueueEvent subId' SubscriptionEose + return emptyUpdates + + Closed subId' msg -> do + enqueueEvent subId' (SubscriptionClosed msg) + modify @RelayPoolState $ \st -> + st { activeConnections = Map.adjust + (\rd -> rd { activeSubscriptions = Map.delete subId' (activeSubscriptions rd) }) + relayURI' + (activeConnections st) + } + return emptyUpdates + + Ok eventId' accepted' msg -> do + modify @RelayPoolState $ \st -> + st { publishStatus = Map.adjust (\relayMap -> + Map.insert relayURI' (if accepted' then Success else Failure msg) relayMap + ) eventId' (publishStatus st) } + return $ emptyUpdates { publishStatusChanged = True } + + Notice msg -> do + modify @RelayPoolState $ \st -> + st { activeConnections = Map.adjust + (\rd -> rd { notices = msg : notices rd }) + relayURI' + (activeConnections st) + } + return $ emptyUpdates { noticesChanged = True } + + Auth challenge -> do + now <- getCurrentTime + kp <- getKeyPair + let unsignedEvent = createCanonicalAuthentication relayURI' challenge (keyPairToPubKeyXO kp) now + signedEventMaybe <- signEvent unsignedEvent kp + case signedEventMaybe of + Just signedEvent -> do + st <- get @RelayPoolState + case Map.lookup relayURI' (activeConnections st) of + Just rd -> do + atomically $ writeTChan (requestChannel rd) (Authenticate signedEvent) + modify @RelayPoolState $ \st' -> + st' { activeConnections = Map.adjust (\rd' -> rd' { authenticated = True }) relayURI' (activeConnections st') } + -- @todo re-sending events? + Nothing -> logError $ "Error handling relay authentication, no channel found: " <> relayURI' + Nothing -> logError "Failed to sign canonical authentication event" + return emptyUpdates + 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' diff --git a/src/Nostr/RelayPool.hs b/src/Nostr/RelayPool.hs index 54e42f0..3bae1df 100644 --- a/src/Nostr/RelayPool.hs +++ b/src/Nostr/RelayPool.hs @@ -2,178 +2,132 @@ module Nostr.RelayPool where -import Control.Monad (forM, forM_, unless) +import Control.Monad (forM_, when) import Data.Map.Strict qualified as Map -import Data.Text qualified as T import Effectful -import Effectful.Concurrent (Concurrent) -import Effectful.Concurrent.STM (TQueue, atomically, newTChanIO, newTQueueIO, writeTChan) -import Effectful.Dispatch.Dynamic (EffectHandler, interpret) -import Effectful.State.Static.Shared (State, evalState, get, modify) +import Effectful.Concurrent (Concurrent, threadDelay) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get) import Effectful.TH +import EffectfulQML import Logging -import Nostr.WebSocket -import Nostr.Types +import Nostr +import Nostr.GiftWrap +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 Types (RelayPoolState(..), RelayData(..), initialRelayPoolState) +import Presentation.KeyMgmt (KeyMgmt) +import Types (AppState(..), ConnectionState(..), RelayData(..), RelayPoolState(..)) +import RelayMgmt (RelayMgmt) +import RelayMgmt qualified as RM + + +data DisconnectReason = UserInitiated | ConnectionFailure + deriving (Show, Eq) + -- | Effect for handling RelayPool operations. data RelayPool :: Effect where - AddRelay :: Relay -> RelayPool m () - Connect :: Relay -> RelayPool m Bool + -- 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 + 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 () - SendEvent :: Event -> [RelayURI] -> RelayPool m () - GetRelays :: RelayPool m [(Relay, ConnectionState)] - StartSubscription :: RelayURI -> [Filter] -> RelayPool m (Maybe (SubscriptionId, TQueue Response)) - StopSubscription :: SubscriptionId -> RelayPool m () - UnsubscribeAllSubscriptionsFromRelay :: RelayURI -> RelayPool m () + AwaitAtLeastOneConnected :: RelayPool m Bool + -- Event Operations + SendEvent :: Event -> RelayPool m () type instance DispatchOf RelayPool = Dynamic makeEffect ''RelayPool -type RelayPoolEff es = (WebSocket :> es, State WebSocketState :> es, Concurrent :> es, Logging :> es, Util :> es) -data RelayPoolError = RelayNotFound RelayURI - deriving (Show, Eq) +-- | RelayPoolEff +type RelayPoolEff es = + ( State AppState :> es + , State RelayPoolState :> es + , Nostr :> es + , RelayConnection :> es + , Publisher :> es + , RelayMgmt :> es + , Subscription :> es + , KeyMgmt :> es + , GiftWrap :> es + , EffectfulQML :> es + , Concurrent :> es + , Logging :> es + , Util :> es + , IOE :> es + ) + -- | Handler for relay pool effects. runRelayPool :: RelayPoolEff es - => Eff (RelayPool : State RelayPoolState : es) a + => Eff (RelayPool : es) a -> Eff es a -runRelayPool action = evalState initialRelayPoolState $ interpret handleRelayPool action - where - handleRelayPool :: RelayPoolEff es => EffectHandler RelayPool (State RelayPoolState : es) - handleRelayPool _ = \case - AddRelay relay -> do - st <- get @RelayPoolState - let relayURI = uri relay - existingRelays = relays st - unless (Map.member relayURI existingRelays) do - reqChan <- newTChanIO - resQueue <- newTQueueIO - let newRelayData = RelayData (info relay) reqChan resQueue [] [] - modify @RelayPoolState $ \st' -> - st' { relays = Map.insert relayURI newRelayData (relays st') } - modify @WebSocketState $ \wsState -> - wsState { connections = Map.insert relayURI (RelayConnectionState Disconnected 0) (connections wsState) } - - Connect relay -> do - let relayURI = uri relay - st <- get @RelayPoolState - case Map.lookup relayURI (relays st) of - Just relayData -> do - wsState <- get @WebSocketState - case Map.lookup relayURI (connections wsState) of - Just relayConnState -> - case connectionStatus relayConnState of - Connected -> do - logDebug $ "Already connected to " <> relayURIToText relayURI - return True - Disconnected -> do - result <- runClient relay (requestChannel relayData) (responseQueue relayData) - case result of - Left e -> do - logError $ "Failed to connect to " <> relayURIToText relayURI <> ": " <> T.pack (show e) - return False - Right _ -> do - return True - Connecting -> do - logDebug $ "Connection already in progress for " <> relayURIToText relayURI - return False - Nothing -> do - logWarning $ "No connection state found for relay: " <> relayURIToText relayURI - return False - Nothing -> do - reqChan <- newTChanIO - resQueue <- newTQueueIO - let newRelayData = RelayData (info relay) reqChan resQueue [] [] - modify @RelayPoolState $ \st' -> - st' { relays = Map.insert relayURI newRelayData (relays st') } - modify @WebSocketState $ \wsState -> - wsState { connections = Map.insert relayURI (RelayConnectionState Connecting 0) (connections wsState) } - result <- runClient relay reqChan resQueue - case result of - Left e -> do - logError $ "Failed to connect to " <> relayURIToText relayURI <> ": " <> T.pack (show e) - return False - Right _ -> return True - - Nostr.RelayPool.Disconnect relayURI -> do - st <- get @RelayPoolState - case Map.lookup relayURI (relays st) of - Just relayData -> do - atomically $ writeTChan (requestChannel relayData) Nostr.Types.Disconnect - logDebug $ T.pack $ "Disconnecting from " ++ T.unpack (relayURIToText relayURI) ++ " ..." +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 - Nothing -> return () + GetGeneralRelays pk -> RM.getGeneralRelays pk - Nostr.RelayPool.DisconnectAll -> do - logDebug $ "Disconnecting from all relays ..." - st <- get @RelayPoolState - forM_ (Map.elems $ relays st) $ \relayData -> - atomically $ writeTChan (requestChannel relayData) Nostr.Types.Disconnect + AddDMRelay pk r -> RM.addDMRelay pk r - Nostr.RelayPool.SendEvent event rs -> do - st <- get @RelayPoolState - forM_ rs $ \relayURI -> do - case Map.lookup relayURI (relays st) of - Just relayData -> atomically $ writeTChan (requestChannel relayData) (Nostr.Types.SendEvent event) - Nothing -> logWarning $ "No channel found for relay: " <> relayURIToText relayURI + RemoveDMRelay pk r -> RM.removeDMRelay pk r - GetRelays -> do - st <- get @RelayPoolState - wst <- get @WebSocketState - relayInfo' <- forM (Map.toList $ relays st) $ \(relayURI, relayData) -> do - let connStatus = maybe Disconnected connectionStatus (Map.lookup relayURI (connections wst)) - return (Relay relayURI (relayInfo relayData), connStatus) - return relayInfo' + GetDMRelays pk -> RM.getDMRelays pk - StartSubscription relayURI filters' -> do - st <- get @RelayPoolState - case Map.lookup relayURI (relays st) of - Just relayData -> do - wst <- get @WebSocketState - case Map.lookup relayURI (connections wst) of - Just RelayConnectionState{connectionStatus = Connected} -> do - subId' <- generateID 8 - atomically $ writeTChan (requestChannel relayData) (Subscribe $ Nostr.Types.Subscription filters' subId') - logDebug $ "Starting new subscription: " <> subId' <> " on relay: " <> relayURIToText relayURI - modify @RelayPoolState $ \st' -> - st' { relays = Map.adjust (\rd -> rd { subscriptions = subId' : subscriptions rd }) relayURI (relays st') } - return $ Just (subId', responseQueue relayData) - _ -> do - logWarning $ "Cannot start subscription: Relay " <> relayURIToText relayURI <> " is not connected." - return Nothing - - _ -> return Nothing - - StopSubscription subId' -> do - st <- get @RelayPoolState - let maybeRelayURI = Map.foldlWithKey' (\acc k v -> - if subId' `elem` subscriptions v then Just k else acc) - Nothing (relays st) - case maybeRelayURI of - Just relayURI -> do - case Map.lookup relayURI (relays st) of - Just relayData -> do - atomically $ writeTChan (requestChannel relayData) (Close subId') - logDebug $ "Closed subscription: " <> subId' <> " on relay: " <> relayURIToText relayURI - modify @RelayPoolState $ \st' -> - st' { relays = Map.adjust (\rd -> rd { subscriptions = filter (/= subId') (subscriptions rd) }) relayURI (relays st') } - Nothing -> logWarning $ "No channel found for relay: " <> relayURIToText relayURI - Nothing -> return () - - UnsubscribeAllSubscriptionsFromRelay relayURI -> do + Connect r -> do + res <- connectRelay r + when res $ handleRelaySubscription r + + Nostr.RelayPool.Disconnect r -> disconnectRelay r + + DisconnectAll -> do st <- get @RelayPoolState - case Map.lookup relayURI (relays st) of - Just relayData -> do - forM_ (subscriptions relayData) $ \subId' -> do - atomically $ writeTChan (requestChannel relayData) (Close subId') - logDebug $ "Closed subscription: " <> subId' <> " on relay: " <> relayURIToText relayURI - modify @RelayPoolState $ \st' -> - st' { relays = Map.adjust (\rd -> rd { subscriptions = [] }) relayURI (relays st') } - Nothing -> logError $ "No channel found for relay: " <> relayURIToText relayURI + 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 100000 -- 100ms 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 02d5587..ee0a281 100644 --- a/src/Nostr/Subscription.hs +++ b/src/Nostr/Subscription.hs @@ -1,211 +1,299 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - module Nostr.Subscription where -import Control.Monad (unless) +import Control.Monad (forM, forM_, replicateM, when) import Data.Aeson (eitherDecode) -import Data.ByteString.Lazy qualified as BSL +import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Lazy (fromStrict) import Data.Map.Strict qualified as Map -import Data.Text (Text, pack) -import Data.Text.Encoding qualified as TE +import Data.Text (pack, unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Effectful import Effectful.Concurrent -import Effectful.Concurrent.STM (TQueue, atomically, readTQueue, flushTQueue, writeTChan) +import Effectful.Concurrent.Async (async) +import Effectful.Concurrent.STM (TQueue, atomically, flushTQueue, newTQueueIO, newTVarIO, readTQueue, readTVar, writeTChan, writeTVar) import Effectful.Dispatch.Dynamic (interpret) -import Effectful.State.Static.Shared (State, get, modify, put) +import Effectful.State.Static.Shared (State, get, modify) import Effectful.TH +import Network.URI (URI(..), parseURI, uriAuthority, uriRegName, uriScheme) +import System.Random (randomIO) import EffectfulQML import Logging -import Nostr -import Nostr.Event (createCanonicalAuthentication, validateEvent) -import Nostr.GiftWrap -import Nostr.Keys (byteStringToHex, keyPairToPubKeyXO) -import Nostr.Types (Event(..), EventId(..), Kind(..), RelayURI, Request(..), Response(..), Tag(..), relayURIToText) -import Nostr.RelayPool +import Nostr.Bech32 (pubKeyXOToBech32) +import Nostr.Event (validateEvent) +import Nostr.GiftWrap (GiftWrap, handleGiftWrapEvent) +import Nostr.Keys (PubKeyXO, byteStringToHex, keyPairToPubKeyXO) +import Nostr.RelayConnection +import Nostr.Types ( Event(..), EventId(..), Filter, Kind(..), Relay(..) + , RelayURI, SubscriptionId, Tag(..), getUri ) +import Nostr.Types qualified as NT import Nostr.Util -import Types (AppState(..), EventConfirmation(..), Follow(..), FollowModel(..), RelayData(..), RelayPoolState(..)) +import Presentation.KeyMgmt (AccountId(..), KeyMgmt, updateProfile) +import RelayMgmt +import Types --- Subscription Effects +-- | Subscription effects data Subscription :: Effect where - HandleResponsesUntilEOSE :: RelayURI -> TQueue Response -> Subscription m () - HandleResponsesUntilClosed :: RelayURI -> TQueue Response -> Subscription m () + NewSubscriptionId :: Subscription m SubscriptionId + Subscribe :: RelayURI -> SubscriptionId -> [Filter] -> Subscription m (Maybe (TQueue SubscriptionEvent)) + StopSubscription :: SubscriptionId -> Subscription m () + HandleEvent :: RelayURI -> SubscriptionId -> [Filter] -> Event -> Subscription m UIUpdates type instance DispatchOf Subscription = Dynamic makeEffect ''Subscription --- Effectful type for Subscription -type SubscriptionEff es = ( RelayPool :> es - , GiftWrap :> es - , State RelayPoolState :> es - , State AppState :> es - , Logging :> es - , Nostr :> es - , Util :> es - , IOE :> es - , Concurrent :> es - , EffectfulQML :> es - ) - --- Run the Subscription effect -runSubscription :: SubscriptionEff es => Eff (Subscription : es) a -> Eff es a + +-- | SubscriptionEff +type SubscriptionEff es = + ( State AppState :> es + , State RelayPoolState :> es + , GiftWrap :> es + , RelayConnection :> es + , KeyMgmt :> es + , RelayMgmt :> es + , Util :> es + , Logging :> es + , Concurrent :> es + , EffectfulQML :> es + , IOE :> es + ) + +-- | Handler for subscription effects. +runSubscription + :: SubscriptionEff es + => Eff (Subscription : es) a + -> Eff es a runSubscription = interpret $ \_ -> \case - HandleResponsesUntilEOSE relayURI' queue -> do - let loop = do - msg <- atomically $ readTQueue queue - msgs <- atomically $ flushTQueue queue - stopped <- processResponsesUntilEOSE relayURI' (msg : msgs) - threadDelay $ 100 * 1000 -- 100ms - unless stopped loop - loop - - HandleResponsesUntilClosed relayURI' queue -> do - let loop = do - msg <- atomically $ readTQueue queue - msgs <- atomically $ flushTQueue queue - stopped <- processResponses relayURI' (msg : msgs) - notifyUI - threadDelay $ 250 * 1000 -- 250ms - unless stopped loop - loop - --- Helper functions - --- | Process responses until EOSE. -processResponsesUntilEOSE :: SubscriptionEff es => RelayURI -> [Response] -> Eff es Bool -processResponsesUntilEOSE _ [] = return False -processResponsesUntilEOSE relayURI' (r:rs) = case r of - EventReceived _ event' -> do - handleEvent event' relayURI' - processResponsesUntilEOSE relayURI' rs - Eose _ -> return True - Closed _ _ -> return True - Ok eventId' accepted' msg -> do - st <- get @AppState - case handleConfirmation eventId' accepted' msg relayURI' st of - Right st' -> do - put @AppState st' - Left err -> do - logWarning $ "Error handling confirmation: " <> err - processResponsesUntilEOSE relayURI' rs - Notice msg -> do - modify $ handleNotice relayURI' msg - processResponsesUntilEOSE relayURI' rs - Auth challenge -> do - handleAuthChallenge relayURI' challenge - processResponsesUntilEOSE relayURI' rs - - --- | Process responses. -processResponses :: SubscriptionEff es => RelayURI -> [Response] -> Eff es Bool -processResponses _ [] = return False -processResponses relayURI' (r:rs) = case r of - EventReceived _ event' -> do - handleEvent event' relayURI' - processResponses relayURI' rs - Eose subId' -> do - logDebug $ "EOSE on subscription " <> subId' - processResponses relayURI' rs - Closed subId msg -> do - logDebug $ "Closed subscription " <> subId <> " with message " <> msg - return True - Ok eventId' accepted' msg -> do - st <- get @AppState - case handleConfirmation eventId' accepted' msg relayURI' st of - Right st' -> do - put @AppState st' - Left err -> do - logWarning $ "Error handling confirmation: " <> err - processResponses relayURI' rs - Notice msg -> do - modify $ handleNotice relayURI' msg - processResponses relayURI' rs - Auth challenge -> do - handleAuthChallenge relayURI' challenge - processResponsesUntilEOSE relayURI' rs - - --- handle auth challenge -handleAuthChallenge :: SubscriptionEff es => RelayURI -> Text -> Eff es () -handleAuthChallenge relayURI' challenge = do - st <- get @AppState - let kp = maybe (error "No key pair available") id $ keyPair st - now <- getCurrentTime - let unsignedEvent = createCanonicalAuthentication relayURI' challenge (keyPairToPubKeyXO kp) now - signedEventMaybe <- signEvent unsignedEvent kp - case signedEventMaybe of - Just signedEvent -> do - st' <- get @RelayPoolState - case Map.lookup relayURI' (relays st') of - Just relayData -> atomically $ writeTChan (requestChannel relayData) (Authenticate signedEvent) - Nothing -> logWarning $ "No channel found for relay: " <> relayURIToText relayURI' - Nothing -> logWarning "Failed to sign canonical authentication event" - - --- | Handle an event. -handleEvent :: SubscriptionEff es => Event -> RelayURI -> Eff es () -handleEvent event' _ = - if not (validateEvent event') + NewSubscriptionId -> generateRandomSubscriptionId + + Subscribe r subId' fs -> createSubscription r subId' fs + + 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 _ _ _ event' -> handleEvent' event' + + +handleEvent' :: SubscriptionEff es => Event -> Eff es UIUpdates +handleEvent' event' = do + -- @todo validate event against filters ?? + if not (validateEvent event') then do - logWarning $ "Invalid event seen: " <> (byteStringToHex $ getEventId (eventId event')) + logWarning $ "Invalid event seen: " <> (byteStringToHex $ getEventId (eventId event')) + pure emptyUpdates else do - case kind event' of - Metadata -> case eitherDecode (BSL.fromStrict $ TE.encodeUtf8 $ content event') of - Right profile -> do - modify $ \st -> - st { profiles = Map.insertWith (\new old -> if snd new > snd old then new else old) - (pubKey event') - (profile, createdAt event') - (profiles st) - } - Left err -> logWarning $ "Failed to decode metadata: " <> pack err - - FollowList -> do - let followList' = [Follow pk relayUri' displayName' | PTag pk relayUri' displayName' <- tags event'] - modify $ \st -> st { follows = FollowModel (Map.insert (pubKey event') followList' (followList $ follows st)) (objRef $ follows st) } - - GiftWrap -> handleGiftWrapEvent event' - - _ -> logDebug $ "Ignoring gift wrapped event of kind: " <> pack (show (kind event')) - - --- | Handle a notice. -handleNotice :: RelayURI -> Text -> RelayPoolState -> RelayPoolState -handleNotice relayURI' msg st = - st { relays = Map.adjust (\rd -> rd { notices = msg : notices rd }) relayURI' (relays st) } - - --- | Handle a confirmation. -handleConfirmation :: Maybe EventId -> Bool -> Text -> RelayURI -> AppState -> Either Text AppState -handleConfirmation mEventId accepted' msg relayURI' st = - let updateConfirmation = EventConfirmation - { relay = relayURI' - , waitingForConfirmation = False - , accepted = accepted' - , message = msg - } - - updateConfirmations :: [EventConfirmation] -> [EventConfirmation] - updateConfirmations [] = [updateConfirmation] - updateConfirmations (conf:confs) - | relay conf == relayURI' && waitingForConfirmation conf = - updateConfirmation : confs - | otherwise = conf : updateConfirmations confs - - in case mEventId of - Just eventId' -> - Right $ st { confirmations = Map.alter - (\case - Nothing -> Just [updateConfirmation] - Just confs -> Just $ updateConfirmations confs) - eventId' - (confirmations st) - } - Nothing -> - if not accepted' - then Left msg - else Right st + logDebug $ "Handling event of kind " <> pack (show $ kind event') <> " with id " <> (byteStringToHex $ getEventId (eventId event')) + case kind event' of + 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) + + modify $ \s -> s { profiles = Map.insertWith (\new old -> if snd new > snd old then new else old) + (pubKey event') + (profile, createdAt event') + (profiles s) + } + + 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 -> do + let followList' = [Follow pk (fmap InboxRelay relay') petName' | PTag pk relay' petName' <- tags event'] + modify $ \st -> st { follows = Map.insert (pubKey event') followList' (follows st) } + pure $ emptyUpdates { followsChanged = True } + + GiftWrap -> do + handleGiftWrapEvent event' + pure $ emptyUpdates { chatsChanged = True } + + RelayListMetadata -> do + logDebug $ pack $ show event' + let validRelayTags = [ r' | RelayTag r' <- tags event', isValidRelayURI (getUri r') ] + ts = createdAt event' + pk = pubKey event' + case validRelayTags of + [] -> do + logWarning $ "No valid relay URIs found in RelayListMetadata event from " + <> (pubKeyXOToBech32 pk) + pure emptyUpdates + relays -> do + importGeneralRelays pk relays ts + -- @todo auto connect to new relays, disconnect from old ones + -- IF the event is from our pubkey + logDebug $ "Updated relay list for " <> (pubKeyXOToBech32 pk) + <> " with " <> pack (show $ length relays) <> " relays" + pure $ emptyUpdates { generalRelaysChanged = True } + + PreferredDMRelays -> do + logDebug $ "Handling PreferredDMRelays event: " <> pack (show event') + 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 + preferredRelays -> do + st <- get @RelayPoolState + case Map.lookup (pubKey event') (dmRelays st) of + Just (existingRelays, ts) -> do + when (ts < createdAt event') $ do + forM_ existingRelays $ \r -> disconnectRelay $ getUri r + importDMRelays (pubKey event') preferredRelays (createdAt event') + forM_ preferredRelays $ \r -> async $ do + connected <- connectRelay $ getUri r + when connected $ handleRelaySubscription $ getUri r + _ -> do + importDMRelays (pubKey event') preferredRelays (createdAt event') + forM_ preferredRelays $ \r -> async $ do + connected <- connectRelay $ getUri r + when connected $ handleRelaySubscription $ getUri r + + pure $ emptyUpdates { dmRelaysChanged = True } + + _ -> do + logDebug $ "Ignoring event of kind: " <> pack (show (kind event')) + pure emptyUpdates + 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' fs = do + st <- get @RelayPoolState + case Map.lookup r (activeConnections st) of + Nothing -> do + logWarning $ "Cannot start subscription: no connection found for relay: " <> r + return Nothing + Just rd -> do + let channel = requestChannel rd + atomically $ writeTChan channel (NT.Subscribe $ NT.Subscription subId' fs) + q <- newTQueueIO + modify @RelayPoolState $ \st' -> + st { activeConnections = Map.adjust + (\rd' -> rd' { activeSubscriptions = Map.insert subId' (SubscriptionDetails subId' fs q 0 0) (activeSubscriptions rd') }) + r + (activeConnections st') + } + return $ pure q + + +-- | Determine relay type and start appropriate subscriptions +handleRelaySubscription :: SubscriptionEff es => RelayURI -> Eff es () +handleRelaySubscription r = do + kp <- getKeyPair + let pk = keyPairToPubKeyXO kp + st <- get @AppState + let followPks = maybe [] (map (\(Follow pk' _ _) -> pk')) $ Map.lookup pk (follows st) + 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 fs = if isDM then Just $ createDMRelayFilters pk followPks + else if isInbox then Just $ createInboxRelayFilters pk followPks + else Nothing + + logInfo $ "Starting subscription for " <> r <> " with filters " <> pack (show fs) + + case fs of + Just fs' -> do + subId' <- generateRandomSubscriptionId + mq <- createSubscription r subId' fs' + 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' + 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 + + +-- | Create DM relay subscription filters +createDMRelayFilters :: PubKeyXO -> [PubKeyXO] -> [Filter] +createDMRelayFilters xo followedPubKeys = + [ NT.metadataFilter (xo : followedPubKeys) + , NT.preferredDMRelaysFilter (xo : followedPubKeys) + , NT.giftWrapFilter xo + ] + + +-- | Create inbox relay subscription filters +createInboxRelayFilters :: PubKeyXO -> [PubKeyXO] -> [Filter] +createInboxRelayFilters xo followedPubKeys = + [ NT.followListFilter (xo : followedPubKeys) + , NT.metadataFilter (xo : followedPubKeys) + , NT.preferredDMRelaysFilter (xo : followedPubKeys) + ] + + +-- | Generate a random subscription ID +generateRandomSubscriptionId :: SubscriptionEff es => Eff es SubscriptionId +generateRandomSubscriptionId = do + bytes <- liftIO $ replicateM 8 randomIO + let byteString = BS.pack bytes + return $ decodeUtf8 $ B16.encode byteString diff --git a/src/Nostr/Types.hs b/src/Nostr/Types.hs index b20b3cd..b5317c3 100644 --- a/src/Nostr/Types.hs +++ b/src/Nostr/Types.hs @@ -34,25 +34,49 @@ import Text.Read (readMaybe) import Nostr.Keys (PubKeyXO(..), Signature, byteStringToHex, exportPubKeyXO, exportSignature) +-- | Represents a relay URI. +type RelayURI = Text --- | Represents a wrapped URI used within a relay. -newtype RelayURI = RelayURI { unRelayURI :: Text } deriving (Eq, Show, Ord) +-- | Represents a relay with its URI and type combined. +data Relay + = InboxRelay RelayURI -- Read-only relay + | OutboxRelay RelayURI -- Write-only relay + | InboxOutboxRelay RelayURI -- Both read and write (also for DM) + deriving (Eq, Generic, Show) --- | Represents the information associated with a relay. -data RelayInfo = RelayInfo - { readable :: Bool - , writable :: Bool - } - deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) +-- | Instance for ordering 'Relay' values based on their URI. +instance Ord Relay where + compare r r' = compare (getUri r) (getUri r') --- | Represents a relay entity containing URI, relay information, and connection status. -data Relay = Relay - { uri :: RelayURI - , info :: RelayInfo - } - deriving (Eq, Generic, Show) + +-- | 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 + InboxRelay uri -> list id [text "r", text uri, text "read"] + OutboxRelay uri -> list id [text "r", text uri, text "write"] + InboxOutboxRelay uri -> list id [text "r", text uri] + + +-- | Instance for parsing a 'Relay' from JSON. +instance FromJSON Relay where + parseJSON = withArray "Relay" $ \arr -> do + case V.toList arr of + ["r", String uri, String "read"] -> + return $ InboxRelay uri + ["r", String uri, String "write"] -> + return $ OutboxRelay uri + ["r", String uri] -> + return $ InboxOutboxRelay uri + _ -> fail "Invalid relay format" -- | Represents a subscription id as text. @@ -61,8 +85,8 @@ type SubscriptionId = Text -- | Represents a subscription. data Subscription = Subscription - { filters :: [Filter] - , subId :: SubscriptionId + { subId :: SubscriptionId + , filters :: [Filter] } deriving (Eq, Generic, Show) @@ -93,7 +117,7 @@ data Request -- | Represents a response from the relay. data Response = EventReceived SubscriptionId Event - | Ok (Maybe EventId) Bool Text + | Ok EventId Bool Text | Eose SubscriptionId | Closed SubscriptionId Text | Notice Text @@ -108,16 +132,18 @@ data StandardPrefix = Duplicate | Pow | Blocked | RateLimited | Invalid | Error -- | The 'Kind' data type represents different kinds of events in the Nostr protocol. data Kind - = Metadata -- NIP-01 - | ShortTextNote -- NIP-01 - | FollowList -- NIP-02 - | EventDeletion -- NIP-09 - | Repost -- NIP-18 - | Reaction -- NIP-25 - | Seal -- NIP-59 - | GiftWrap -- NIP-59 - | DirectMessage -- NIP-17 - | CanonicalAuthentication -- NIP-42 + = Metadata -- NIP-01 (kind 0) + | ShortTextNote -- NIP-01 (kind 1) + | FollowList -- NIP-02 (kind 3) + | EventDeletion -- NIP-09 (kind 5) + | Repost -- NIP-18 (kind 6) + | Reaction -- NIP-25 (kind 7) + | Seal -- NIP-59 (kind 13) + | GiftWrap -- NIP-59 (kind 1059) + | DirectMessage -- NIP-17 (kind 14) + | PreferredDMRelays -- NIP-17 (kind 10050) + | CanonicalAuthentication -- NIP-42 (kind 22242) + | RelayListMetadata -- NIP-65 (kind 10002) | UnknownKind Int deriving (Eq, Generic, Read, Show) @@ -135,7 +161,7 @@ data Relationship = Reply | Root data Tag = ETag EventId (Maybe RelayURI) (Maybe Relationship) | PTag PubKeyXO (Maybe RelayURI) (Maybe DisplayName) - | RelayTag RelayURI + | RelayTag Relay | ChallengeTag Text | GenericTag [Value] deriving (Eq, Generic, Show) @@ -385,7 +411,7 @@ parseJSONSafe v = case parseEither parseJSON v of -- | Parses a maybe relay URI from a JSON value. parseMaybeRelayURI :: Value -> Parser (Maybe RelayURI) -parseMaybeRelayURI (String s) = pure (Just (RelayURI s)) +parseMaybeRelayURI (String s) = pure (Just s) parseMaybeRelayURI Null = pure Nothing parseMaybeRelayURI _ = fail "Expected string or null for RelayURI" @@ -406,15 +432,22 @@ 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 + [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" [relayVal] -> do relayURI' <- parseRelayURI relayVal - return $ RelayTag relayURI' + return $ RelayTag (InboxOutboxRelay relayURI') _ -> fail "Invalid RelayTag format" -- | Parses a RelayURI from a JSON value. parseRelayURI :: Value -> Parser RelayURI -parseRelayURI (String s) = return (RelayURI s) +parseRelayURI (String s) = return s parseRelayURI _ = fail "Expected string for RelayURI" @@ -440,7 +473,7 @@ instance ToJSON Tag where [ text "e" , text $ decodeUtf8 $ B16.encode $ getEventId eventId ] ++ - (maybe [] (\r -> [text $ unRelayURI r]) relayURL) ++ + (maybe [] (\r -> [text r]) relayURL) ++ (case marker of Just Reply -> [text "reply"] Just Root -> [text "root"] @@ -450,9 +483,13 @@ instance ToJSON Tag where [ text "p" , toEncoding xo ] ++ - (maybe [] (\r -> [text $ unRelayURI r]) relayURL) ++ + (maybe [] (\r -> [text r]) relayURL) ++ (maybe [] (\n -> [text n]) name) - toEncoding (RelayTag relayURI') = list id [text "relay", text (relayURIToText relayURI')] + toEncoding (RelayTag 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] toEncoding (ChallengeTag challenge) = list id [text "challenge", text challenge] toEncoding (GenericTag values) = list toEncoding values @@ -482,13 +519,10 @@ instance FromJSON Response where event <- parseJSON $ arr V.! 2 return $ EventReceived subId' event "OK" -> do - id' <- parseJSON $ arr V.! 1 :: Parser (Maybe Text) + id' <- parseJSON $ arr V.! 1 :: Parser EventId bool <- parseJSON $ arr V.! 2 message <- parseJSON $ arr V.! 3 - let eventId = id' >>= \t -> if T.null t - then Nothing - else EventId <$> decodeHex t - return $ Ok eventId bool message + return $ Ok id' bool message "EOSE" -> do subId' <- parseJSON $ arr V.! 1 return $ Eose subId' @@ -515,42 +549,11 @@ instance ToJSON Request where toEncoding req = case req of Authenticate event -> list id [text "AUTH", toEncoding event] SendEvent event -> list id [text "EVENT", toEncoding event] - Subscribe (Subscription filters subId) -> list id $ text "REQ" : text subId : map toEncoding (toList filters) + Subscribe (Subscription subId filters) -> list id $ text "REQ" : text subId : map toEncoding (toList filters) Close subId -> list text ["CLOSE", subId] Disconnect -> list text ["DISCONNECT"] --- | Converts a `RelayURI` into its JSON representation. -instance FromJSON RelayURI where - parseJSON = withText "RelayURI" (pure . RelayURI) - - --- | Parses a JSON value into a `RelayURI`. -instance ToJSON RelayURI where - toJSON (RelayURI uri) = String uri - toEncoding (RelayURI uri) = toEncoding uri - - --- | Instance for ordering 'Relay' values based on their 'uri'. -instance Ord Relay where - compare (Relay r _) (Relay r' _) = compare r r' - - --- | Instance for parsing a 'Relay' from JSON. -instance FromJSON Relay where - parseJSON = withObject "Relay" $ \r -> do - uri' <- r .: "uri" - info' <- r .: "info" - return $ Relay uri' info' - - --- | Instance for converting a 'Relay' to JSON. -instance ToJSON Relay where - toEncoding r = pairs $ - "uri" .= unRelayURI (uri r) <> - "info" .= info r - - -- | 'FromJSON' instance for 'Kind'. -- This allows parsing JSON numbers into 'Kind' values. instance FromJSON Kind where @@ -565,7 +568,9 @@ instance FromJSON Kind where 13 -> return Seal 1059 -> return GiftWrap 14 -> return DirectMessage + 10050 -> return PreferredDMRelays 22242 -> return CanonicalAuthentication + 10002 -> return RelayListMetadata _ -> return $ UnknownKind n Nothing -> fail "Expected an integer for Kind" @@ -582,7 +587,9 @@ instance ToJSON Kind where toEncoding Seal = toEncoding (13 :: Int) toEncoding GiftWrap = toEncoding (1059 :: Int) toEncoding DirectMessage = toEncoding (14 :: Int) + toEncoding PreferredDMRelays = toEncoding (10050 :: Int) toEncoding CanonicalAuthentication = toEncoding (22242 :: Int) + toEncoding RelayListMetadata = toEncoding (10002 :: Int) toEncoding (UnknownKind n) = toEncoding n @@ -625,61 +632,47 @@ instance FromJSON Profile where -- Relay Helper functions -- | Provides a default list of relays. -defaultRelays :: [Relay] +defaultRelays :: ([Relay], Int) defaultRelays = - [ Relay (RelayURI "wss://nos.lol") (RelayInfo True True) - , Relay (RelayURI "wss://auth.nostr1.com") (RelayInfo True True) - , Relay (RelayURI "wss://nostr.mom") (RelayInfo True True) - ] - - --- | Retrieves the textual representation of the relay's URI. -relayName :: Relay -> Text -relayName r = unRelayURI $ uri r - - --- | Converts a 'RelayURI' to a 'Text'. -relayURIToText :: RelayURI -> Text -relayURIToText = unRelayURI + ( [ InboxOutboxRelay "wss://nos.lol" + , InboxOutboxRelay "wss://nostr.mom" + ], + 0 + ) -- | Extracts the scheme of a relay's URI. -extractScheme :: Relay -> Maybe Text -extractScheme r = +extractScheme :: RelayURI -> Maybe Text +extractScheme u = case T.splitOn "://" u of (scheme:_) -> Just scheme _ -> Nothing - where - u = unRelayURI $ uri r -- | Extracts the hostname of a relay's URI. -extractHostname :: Relay -> Maybe Text -extractHostname r = +extractHostname :: RelayURI -> Maybe Text +extractHostname u = case T.splitOn "://" u of (_:rest:_) -> Just $ T.takeWhile (/= ':') $ T.dropWhile (== '/') rest _ -> Nothing - where - u = unRelayURI $ uri r -- | Extracts the port of a relay's URI. -extractPort :: Relay -> Int -extractPort r = +extractPort :: RelayURI -> Int +extractPort u = case T.splitOn ":" $ T.dropWhile (/= ':') $ T.dropWhile (/= '/') $ T.dropWhile (/= ':') u of (_:portStr:_) -> maybe (defaultPort scheme) id $ readMaybe $ T.unpack portStr _ -> defaultPort scheme where - u = unRelayURI $ uri r - scheme = extractScheme r + scheme = extractScheme u defaultPort (Just "wss") = 443 defaultPort (Just "ws") = 80 defaultPort _ = 443 -- | Extracts the path of a relay's URI. -extractPath :: Relay -> Text -extractPath (Relay (RelayURI u) _) = +extractPath :: RelayURI -> Text +extractPath u = case T.splitOn "://" u of (_:rest:_) -> let withoutHost = T.dropWhile (/= '/') rest @@ -689,7 +682,7 @@ extractPath (Relay (RelayURI u) _) = -- | Checks if two relays are the same based on URI. sameRelay :: Relay -> Relay -> Bool -sameRelay = (==) `on` uri +sameRelay = (==) `on` getUri -- Helper functions to create specific filters @@ -745,3 +738,28 @@ giftWrapFilter xo = , limit = Just 500 , fTags = Just $ Map.fromList [('p', [byteStringToHex $ exportPubKeyXO xo])] } + + +-- | Creates a filter for preferred DM relays. +preferredDMRelaysFilter :: [PubKeyXO] -> Filter +preferredDMRelaysFilter authors = Filter + { ids = Nothing + , authors = Just authors + , kinds = Just [PreferredDMRelays] + , since = Nothing + , until = Nothing + , limit = Just 500 + , fTags = Nothing + } + + +eventFilter :: EventId -> Filter +eventFilter eid = Filter + { ids = Just [eid] + , authors = Nothing + , kinds = Nothing + , since = Nothing + , until = Nothing + , limit = Nothing + , fTags = Nothing + } diff --git a/src/Nostr/Util.hs b/src/Nostr/Util.hs index 462e9a9..cf1273b 100644 --- a/src/Nostr/Util.hs +++ b/src/Nostr/Util.hs @@ -3,21 +3,19 @@ module Nostr.Util where -import Control.Monad (replicateM) -import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as B16 -import Data.Text (Text) -import Data.Text.Encoding qualified as TE import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Effectful import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get) import Effectful.TH -import System.Random (randomIO) + +import Nostr.Keys (KeyPair) +import Types (AppState(..)) -- | Effect for generating unique IDs. data Util :: Effect where - GenerateID :: Int -> Util m Text GetCurrentTime :: Util m Int + GetKeyPair :: Util m KeyPair type instance DispatchOf Util = Dynamic @@ -25,16 +23,14 @@ makeEffect ''Util -- | Handler for the IDGen effect. runUtil - :: IOE :> es + :: (State AppState :> es, IOE :> es) => Eff (Util : es) a -> Eff es a runUtil = interpret $ \_ -> \case - - GenerateID n -> do - bytes <- liftIO $ replicateM n randomIO - let byteString = BS.pack bytes - return $ TE.decodeUtf8 $ B16.encode byteString - GetCurrentTime -> do n <- liftIO $ fmap (floor . (realToFrac :: POSIXTime -> Double)) getPOSIXTime return n + + GetKeyPair -> do + st <- get @AppState + return $ maybe (error "No key pair found in app state") id $ keyPair st diff --git a/src/Nostr/WebSocket.hs b/src/Nostr/WebSocket.hs deleted file mode 100644 index d12302a..0000000 --- a/src/Nostr/WebSocket.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - -module Nostr.WebSocket where - -import Data.Aeson (eitherDecode, encode) -import Data.ByteString.Lazy qualified as BSL -import Data.Map.Strict qualified as Map -import Data.Text qualified as T -import Effectful -import Effectful.Concurrent (Concurrent, forkIO, threadDelay) -import Effectful.Concurrent.Async (async, race, waitAnyCancel) -import Effectful.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -import Effectful.Concurrent.STM (TChan, TQueue, atomically, readTChan, writeTQueue) -import Effectful.Dispatch.Dynamic (EffectHandler, interpret) -import Effectful.State.Static.Shared (State, evalState, get, modify) -import Effectful.TH -import Control.Exception qualified as E -import Network.WebSockets qualified as WS -import Wuss qualified as Wuss - -import Logging -import Nostr.Types - - --- | WebSocket connection state. -data ConnectionState = Connected | Disconnected | Connecting - deriving (Show, Eq) - - --- | WebSocket connection state for a specific relay. -data RelayConnectionState = RelayConnectionState - { connectionStatus :: ConnectionState - , connectionRetries :: Int - } - - --- | WebSocket state for all relays. -data WebSocketState = WebSocketState - { connections :: Map.Map RelayURI RelayConnectionState - , maxRetries :: Int - } - - --- | Custom error type for WebSocket connections -data ConnectionError - = ConnectionFailed - | Timeout - | InvalidRelayConfig - | MaxRetriesReached - deriving (Show, Eq) - - --- | Effect for handling WebSocket operations. -data WebSocket :: Effect where - RunClient :: Relay -> TChan Request -> TQueue Response -> WebSocket m (Either ConnectionError ()) - - --- | Dispatch for WebSocket. -type instance DispatchOf WebSocket = Dynamic - - -makeEffect ''WebSocket - - --- | Effectful environment for WebSocket operations. -type WebSocketEff es = (Concurrent :> es, IOE :> es, Logging :> es) - - --- | Handler for web socket effects. -runWebSocket - :: WebSocketEff es - => Int -- ^ Maximum number of reconnection attempts - -> Eff (WebSocket : State WebSocketState : es) a - -> Eff es a -runWebSocket maxRetries' action = evalState (WebSocketState Map.empty maxRetries') $ interpret handleWebSocket action - where - handleWebSocket :: WebSocketEff es => EffectHandler WebSocket (State WebSocketState : es) - handleWebSocket _ = \case - RunClient relay requestChan responseQueue -> do - result <- runClientWithRetry relay requestChan responseQueue - case result of - Left err -> do - logError $ "Failed to connect after max retries: " <> T.pack (show err) - return $ Left err - Right _ -> return $ Right () - -runClientWithRetry - :: (WebSocketEff es, State WebSocketState :> es) - => Relay - -> TChan Request - -> TQueue Response - -> Eff es (Either ConnectionError ()) -runClientWithRetry relay requestChan responseQueue = go - where - go = do - st <- get @WebSocketState - let relayState = Map.findWithDefault (RelayConnectionState Disconnected 0) (uri relay) (connections st) - if connectionRetries relayState >= maxRetries st - then do - logError $ "Max retries reached for " <> relayName relay - return $ Left MaxRetriesReached - else do - modify @WebSocketState $ \s -> s { connections = Map.insert (uri relay) (relayState { connectionStatus = Connecting }) (connections s) } - result <- attemptConnection relay requestChan responseQueue - case result of - Left err -> do - logWarning $ "Connection attempt failed: " <> T.pack (show err) - modify @WebSocketState $ \s -> - let updatedState = relayState { connectionRetries = connectionRetries relayState + 1, connectionStatus = Disconnected } - in s { connections = Map.insert (uri relay) updatedState (connections s) } - backoffTime <- calculateBackoffTime (connectionRetries relayState) - logDebug $ "Retrying in " <> T.pack (show backoffTime) <> " seconds" - threadDelay $ backoffTime * 1000000 - go - Right _ -> do - modify @WebSocketState $ \s -> - let updatedState = RelayConnectionState Connected 0 - in s { connections = Map.insert (uri relay) updatedState (connections s) } - return $ Right () - -calculateBackoffTime :: Int -> Eff es Int -calculateBackoffTime retries = do - let baseDelay = 1 - maxDelay = 60 - return $ min maxDelay (baseDelay * (2 ^ retries)) - -attemptConnection - :: (WebSocketEff es, State WebSocketState :> es) - => Relay - -> TChan Request - -> TQueue Response - -> Eff es (Either ConnectionError ()) -attemptConnection relay requestChan responseQueue = do - case (extractHostname relay, extractScheme relay) of - (Just host', Just scheme') -> do - let options = WS.defaultConnectionOptions - { WS.connectionCompressionOptions = - WS.PermessageDeflateCompression WS.defaultPermessageDeflate - } - let connectAction = case scheme' of - "wss" -> Wuss.runSecureClientWith - (T.unpack host') - (fromIntegral $ extractPort relay) - (T.unpack $ extractPath relay) - options - [] - "ws" -> WS.runClientWith - (T.unpack host') - (extractPort relay) - (T.unpack $ extractPath relay) - options - [] - _ -> \_ -> return () -- Do nothing for invalid scheme - - logDebug $ "Attempting to connect to " <> relayName relay - connectionMVar <- newEmptyMVar - errorMVar <- newEmptyMVar - - -- Fork a new thread to handle the connection - _ <- forkIO $ withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> do - result <- liftIO $ E.try @E.SomeException $ connectAction $ \conn -> runE $ do - -- Signal that the connection is established - putMVar connectionMVar conn - - logDebug $ "Connected to " <> relayName relay - modify @WebSocketState $ \st -> - let updatedState = RelayConnectionState Connected 0 - in st { connections = Map.insert (uri relay) updatedState (connections st) } - - -- Start receive and send loops - receiveThread <- async $ receiveWs relay conn responseQueue - sendThread <- async $ sendWs relay conn requestChan - - -- Wait for either thread to finish (which would indicate a disconnection) - _ <- waitAnyCancel [receiveThread, sendThread] - - logDebug $ "Disconnected from " <> relayName relay - modify @WebSocketState $ \st -> - let updatedState = RelayConnectionState Disconnected 0 - in st { connections = Map.insert (uri relay) updatedState (connections st) } - - case result of - Left _ -> runE $ do - logError $ "Connection error on " <> relayName relay - putMVar errorMVar ConnectionFailed - Right _ -> return () - - -- Wait for either the connection to be established or an error to occur - _ <- forkIO $ do - threadDelay 15000000 -- 15 seconds timeout - putMVar errorMVar Timeout - - result <- race (takeMVar connectionMVar) (takeMVar errorMVar) - - case result of - Left _ -> return $ Right () - Right err -> return $ Left err - - _ -> do - logError $ "Invalid relay configuration: " <> T.pack (show relay) - return $ Left InvalidRelayConfig - --- | Receive messages from the relay. -receiveWs - :: (WebSocketEff es, State WebSocketState :> es) - => Relay - -> WS.Connection - -> TQueue Response - -> Eff es () -receiveWs relay conn responseQueue = do - msgResult <- liftIO (E.try (WS.receiveData conn) :: IO (Either E.SomeException BSL.ByteString)) - case msgResult of - Left e -> do - handleConnectionError relay "Receive" e - return () - Right msg -> - case eitherDecode msg of - Right response -> do - atomically $ writeTQueue responseQueue response - receiveWs relay conn responseQueue - Left err -> do - logWarning $ "Could not decode server response: " <> T.pack err - --logWarning $ "Raw message: " <> T.pack (show msg) - receiveWs relay conn responseQueue - - --- | Send messages to the relay. -sendWs - :: (WebSocketEff es, State WebSocketState :> es) - => Relay - -> WS.Connection - -> TChan Request - -> Eff es () -sendWs relay conn channel = do - msg <- atomically $ readTChan channel - case msg of - Nostr.Types.Disconnect -> do - liftIO $ WS.sendClose conn (T.pack "Bye!") - logDebug $ "Sent close message." - sendWs relay conn channel - msg' -> do - result <- liftIO $ E.try @E.SomeException $ WS.sendTextData conn $ encode msg' - case result of - Left e -> do - handleConnectionError relay "Send" e - return () - Right _ -> do - logDebug $ "Sent message to relay " <> relayName relay - sendWs relay conn channel - - --- | Handle connection errors -handleConnectionError - :: (WebSocketEff es, State WebSocketState :> es) - => Relay - -> T.Text - -> E.SomeException - -> Eff es () -handleConnectionError relay operation e = do - logError $ operation <> " error for " <> relayName relay <> ": " <> T.pack (show e) - modify @WebSocketState $ \st -> - let updatedState = RelayConnectionState Disconnected 0 - in st { connections = Map.insert (uri relay) updatedState (connections st) } diff --git a/src/Presentation/KeyMgmt.hs b/src/Presentation/KeyMgmt.hs index 8a6f1e1..c122d8e 100644 --- a/src/Presentation/KeyMgmt.hs +++ b/src/Presentation/KeyMgmt.hs @@ -7,7 +7,7 @@ module Presentation.KeyMgmt where import Control.Monad (filterM) -import Data.Aeson (FromJSON (..), eitherDecode) +import Data.Aeson (FromJSON (..), eitherDecode, encode) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe) @@ -28,10 +28,12 @@ import Effectful.FileSystem ) import Effectful.FileSystem.IO.ByteString qualified as FIOE (readFile, writeFile) import Effectful.FileSystem.IO.ByteString.Lazy qualified as BL -import Effectful.State.Static.Shared (State, get, modify) +import Effectful.State.Static.Shared (State, get, gets, modify) import Effectful.TH import EffectfulQML import Graphics.QML hiding (fireSignal, runEngineLoop) + +import Logging import Nostr import Nostr.Bech32 import Nostr.Keys ( KeyPair, PubKeyXO, SecKey, derivePublicKeyXO @@ -39,15 +41,16 @@ import Nostr.Keys ( KeyPair, PubKeyXO, SecKey, derivePublicKeyXO import Nostr.Types hiding (displayName, picture) import System.FilePath (takeFileName, ()) import Text.Read (readMaybe) +import qualified Nostr.Types as NT -- | Account. data Account = Account - { nsec :: SecKey, - npub :: PubKeyXO, - displayName :: Maybe Text, - picture :: Maybe Text, - relays :: [Relay] + { accountSecKey :: SecKey, + accountPubKeyXO :: PubKeyXO, + accountDisplayName :: Maybe Text, + accountPicture :: Maybe Text, + accountRelays :: ([Relay], Int) } deriving (Eq, Show) @@ -85,7 +88,8 @@ type KeyMgmtEff es = ( State KeyMgmtState :> es , Nostr :> es , FileSystem :> es , IOE :> es - , EffectfulQML :> es ) + , EffectfulQML :> es + , Logging :> es ) -- | Key Management Effects. data KeyMgmt :: Effect where @@ -93,6 +97,8 @@ data KeyMgmt :: Effect where ImportSeedphrase :: ObjRef () -> Text -> Text -> KeyMgmt m Bool GenerateSeedphrase :: ObjRef () -> KeyMgmt m () RemoveAccount :: ObjRef () -> Text -> KeyMgmt m () + UpdateRelays :: AccountId -> ([Relay], Int) -> KeyMgmt m () + UpdateProfile :: AccountId -> Profile -> KeyMgmt m () type instance DispatchOf KeyMgmt = Dynamic @@ -115,7 +121,7 @@ type instance DispatchOf KeyMgmtUI = Dynamic makeEffect ''KeyMgmtUI --- | Handler for the logging effect to stdout. +-- | Run the Key Management effect. runKeyMgmt :: KeyMgmtEff es => Eff (KeyMgmt : es) a -> Eff es a runKeyMgmt = interpret $ \_ -> \case ImportSecretKey obj input -> do @@ -185,6 +191,35 @@ 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 + { accountDisplayName = NT.displayName profile + , accountPicture = NT.picture profile + }) 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 "profile.json") (encode profile) + Nothing -> do + logError $ "Account not found: " <> accountId aid + return () -- | Run the Key Management UI effect. runKeyMgmtUI :: KeyMgmgtUIEff es => Eff (KeyMgmtUI : es) a -> Eff es a @@ -209,10 +244,10 @@ runKeyMgmtUI action = interpret handleKeyMgmtUI action accountClass <- newClass - [ prop "nsec" (secKeyToBech32 . nsec), - prop "npub" (pubKeyXOToBech32 . npub), - mprop "displayName" displayName, - mprop "picture" picture + [ prop "nsec" (secKeyToBech32 . accountSecKey), + prop "npub" (pubKeyXOToBech32 . accountPubKeyXO), + mprop "displayName" accountDisplayName, + mprop "picture" accountPicture ] accountPool' <- newFactoryPool (newObject accountClass) @@ -302,7 +337,7 @@ loadAccount :: (FileSystem :> es) => FilePath -> FilePath -> Eff es (Maybe Accou loadAccount storageDir npubDir = do let dirPath = storageDir npubDir nsecContent <- readFileMaybe (dirPath "nsec") - relayList <- readJSONFile (dirPath "relays.json") + relayData <- readJSONFile (dirPath "relays.json") profile <- readJSONFile (dirPath "profile.json") return $ do @@ -311,11 +346,11 @@ loadAccount storageDir npubDir = do Just Account - { nsec = nsecKey, - npub = pubKeyXO, - relays = fromMaybe defaultRelays relayList, - displayName = profile >>= \(Profile _ d _ _ _ _) -> d, - picture = profile >>= \(Profile _ _ _ p _ _) -> p + { accountSecKey = nsecKey, + accountPubKeyXO = pubKeyXO, + accountRelays = fromMaybe defaultRelays relayData, + accountDisplayName = profile >>= \(Profile _ d _ _ _ _) -> d, + accountPicture = profile >>= \(Profile _ _ _ p _ _) -> p } -- | Read a file and return its contents as a Maybe Text. @@ -343,9 +378,9 @@ accountFromKeyPair kp = (AccountId newNpub, account) newNpub = pubKeyXOToBech32 $ keyPairToPubKeyXO kp account = Account - { nsec = keyPairToSecKey kp, - npub = keyPairToPubKeyXO kp, - relays = defaultRelays, - displayName = Nothing, - picture = Nothing + { accountSecKey = keyPairToSecKey kp, + accountPubKeyXO = keyPairToPubKeyXO kp, + accountRelays = defaultRelays, + accountDisplayName = Nothing, + accountPicture = Nothing } diff --git a/src/Presentation/RelayMgmt.hs b/src/Presentation/RelayMgmt.hs new file mode 100644 index 0000000..d216f70 --- /dev/null +++ b/src/Presentation/RelayMgmt.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Presentation.RelayMgmt 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 +import Graphics.QML hiding (fireSignal, runEngineLoop) + +import EffectfulQML (EffectfulQMLState(..)) +import Logging +import Nostr.Keys (keyPairToPubKeyXO) +import Nostr.RelayPool +import Nostr.Types hiding (displayName, picture) +import Nostr.Util +import Types (AppState(..), ConnectionState(..), RelayData(..), RelayPoolState(..), UIReferences(..)) + + +data RelayType = DMRelays | InboxRelays | OutboxRelays + +-- | Relay Management UI Effect. +type RelayMgmgtUIEff es = + ( State AppState :> es + , State RelayPoolState :> es + , State EffectfulQMLState :> es + , RelayPool :> es + , Logging :> es + , Concurrent :> es + , Util :> es + , IOE :> es + ) + +-- | Key Management Effect for creating QML UI. +data RelayMgmtUI :: Effect where + CreateUI :: SignalKey (IO ()) -> RelayMgmtUI m (ObjRef ()) + + +-- | Dispatch for Key Management UI Effect. +type instance DispatchOf RelayMgmtUI = Dynamic + + +makeEffect ''RelayMgmtUI + + +-- | Run the Relay Management UI effect. +runRelayMgmtUI :: RelayMgmgtUIEff es => Eff (RelayMgmtUI : es) a -> Eff es a +runRelayMgmtUI action = interpret handleRelayMgmtUI action + where + handleRelayMgmtUI :: RelayMgmgtUIEff es => EffectHandler RelayMgmtUI es + handleRelayMgmtUI _ = \case + CreateUI changeKey -> withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> do + dmRelayClass <- newClass [ + defPropertySigRO' "url" changeKey $ \obj -> return $ fromObjRef obj, + + defPropertySigRO' "connectionState" changeKey $ \obj -> runE $ do + let uri' = fromObjRef obj + pst <- get @RelayPoolState + return $ getConnectionStateText uri' pst, + + defPropertySigRO' "connectionRetries" changeKey $ \obj -> runE $ do + let uri' = fromObjRef obj + pst <- get @RelayPoolState + 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 + return $ case Map.lookup uri' (activeConnections pst) of + Just rd -> notices rd + Nothing -> [] + ] + + relayClass <- newClass [ + defPropertySigRO' "url" changeKey $ \obj -> return $ fromObjRef obj, + + defPropertySigRO' "connectionState" changeKey $ \obj -> runE $ do + let uri' = fromObjRef obj + pst <- get @RelayPoolState + 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) + 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) + return $ isInDMRelays || isInGeneralRelays, + + defPropertySigRO' "connectionRetries" changeKey $ \obj -> runE $ do + let uri' = fromObjRef obj + pst <- get @RelayPoolState + 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 + return $ case Map.lookup uri' (activeConnections pst) of + Just rd -> notices rd + Nothing -> [] + ] + + dmRelayPool <- newFactoryPool (newObject dmRelayClass) + generalRelayPool <- newFactoryPool (newObject relayClass) + + contextClass <- newClass [ + defPropertySigRO' "dmRelays" changeKey $ \obj -> do + runE $ logDebug "dmRelays property" + runE $ modify @EffectfulQMLState $ \s -> s { + uiRefs = (uiRefs s) { dmRelaysObjRef = Just obj } + } + appState <- runE $ get @AppState + case keyPair appState of + Nothing -> return [] + Just kp -> do + let pk = keyPairToPubKeyXO kp + (relaysWithStatus, _) <- runE $ getDMRelays pk + mapM (\(relay, _status) -> getPoolObject dmRelayPool (getUri relay)) relaysWithStatus, + + defPropertySigRO' "generalRelays" changeKey $ \obj -> do + runE $ logDebug "generalRelays property" + runE $ modify @EffectfulQMLState $ \s -> s { + uiRefs = (uiRefs s) { generalRelaysObjRef = Just obj } + } + appState <- runE $ get @AppState + case keyPair appState of + 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, + + defMethod' "addDMRelay" $ \_ input -> runE $ do + kp <- getKeyPair + addDMRelay (keyPairToPubKeyXO kp) input, + + defMethod' "removeDMRelay" $ \_ input -> runE $ do + kp <- getKeyPair + removeDMRelay (keyPairToPubKeyXO kp) input, + + defMethod' "addGeneralRelay" $ \_ input r w -> runE $ do + kp <- getKeyPair + addGeneralRelay (keyPairToPubKeyXO kp) input r w, + + 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 + ] + + 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 uri pst = case Map.lookup uri (activeConnections pst) of + Just rd -> case connectionState rd of + Connected -> "Connected" + Disconnected -> "Disconnected" + Connecting -> "Connecting" + Nothing -> "Disconnected" diff --git a/src/RelayMgmt.hs b/src/RelayMgmt.hs new file mode 100644 index 0000000..f01020b --- /dev/null +++ b/src/RelayMgmt.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE BlockArguments #-} + +module RelayMgmt where + +import Control.Monad (forM) +import Data.List (dropWhileEnd) +import Data.Map.Strict qualified as Map +import Data.Text (pack, unpack) +import Effectful +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.State.Static.Shared (State, get, gets, modify) +import Effectful.TH +import Network.URI (URI(..), parseURI, uriAuthority, uriPort, uriRegName, uriScheme) + +import EffectfulQML +import Logging +import Nostr +import Nostr.Bech32 (pubKeyXOToBech32) +import Nostr.Event (createPreferredDMRelaysEvent, createRelayListMetadataEvent) +import Nostr.Keys (PubKeyXO) +import Nostr.Publisher +import Nostr.Types (Relay(..), RelayURI, getUri) +import Nostr.Util +import Presentation.KeyMgmt (AccountId(..), KeyMgmt, updateRelays) +import Types (ConnectionState(..), RelayPoolState(..), RelayData(..)) + + +-- | 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) + -- 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) + +type instance DispatchOf RelayMgmt = Dynamic + +makeEffect ''RelayMgmt + + +-- | RelayMgmtEff +type RelayMgmtEff es = + ( State RelayPoolState :> es + , Nostr :> es + , Publisher :> es + , KeyMgmt :> es + , Logging :> es + , EffectfulQML :> es + , Util :> es + ) + + +-- | Handler for relay pool effects. +runRelayMgmt + :: RelayMgmtEff es + => Eff (RelayMgmt : es) a + -> Eff es a +runRelayMgmt = interpret $ \_ -> \case + ImportGeneralRelays pk rs ts -> do + 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 + return False + else do + let relay'' = case (r, w) of + (True, True) -> InboxOutboxRelay $ normalizeRelayURI relay' + (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') + 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 + 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" + return True + + RemoveGeneralRelay pk r -> do + let r' = normalizeRelayURI r + modify $ \st -> st + { generalRelays = Map.adjust (removeAllRelayTypes r') pk (generalRelays st) } + updatedRelays <- gets (Map.findWithDefault ([], 0) pk . generalRelays) + updateRelays (AccountId $ pubKeyXOToBech32 pk) updatedRelays + notifyRelayStatus + 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 + if newRelay `elem` existingRelays + then return False + else do + now <- getCurrentTime + modify $ \st' -> st' + { dmRelays = Map.insertWith + (\(_, newTime) (oldRelays, _) -> + ([newRelay] ++ oldRelays, newTime)) + pk + ([newRelay], now) + (dmRelays st') } + notifyRelayStatus + kp <- getKeyPair + st' <- get @RelayPoolState + let (rs, _) = Map.findWithDefault ([], 0) pk (dmRelays st') + let unsigned = createPreferredDMRelaysEvent (map getUri rs) pk now + signed <- signEvent unsigned kp + case signed of + Just signed' -> broadcast signed' + Nothing -> logError $ "Failed to sign preferred DM relays event" + return True + + RemoveDMRelay pk r -> do + let r' = normalizeRelayURI r + now <- getCurrentTime + modify @RelayPoolState $ \st -> st + { dmRelays = Map.adjust (removeDMRelay' now $ InboxOutboxRelay r') pk (dmRelays st) } + notifyRelayStatus + kp <- getKeyPair + st <- get @RelayPoolState + let (rs, _) = Map.findWithDefault ([], 0) pk (dmRelays st) + let unsigned = createPreferredDMRelaysEvent (map getUri rs) pk now + signed <- signEvent unsigned kp + case signed of + Just signed' -> broadcast signed' + Nothing -> logError $ "Failed to sign preferred DM relays event" + where + removeDMRelay' newTime r'' (relays, _) = (filter (/= r'') relays, newTime) + + 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) + + +-- | Remove all variants of a relay URI +removeAllRelayTypes :: RelayURI -> ([Relay], Int) -> ([Relay], Int) +removeAllRelayTypes uri (relays, timestamp) = + ( filter (\r -> not $ matchesURI r uri) relays + , timestamp + ) + where + matchesURI (InboxRelay u) uri' = u == uri' + matchesURI (OutboxRelay u) uri' = u == uri' + matchesURI (InboxOutboxRelay u) uri' = u == uri' + + +-- | Normalize a relay URI according to RFC 3986 +normalizeRelayURI :: RelayURI -> RelayURI +normalizeRelayURI uri = case parseURI (unpack uri) of + Just uri' -> pack $ + (if uriScheme uri' == "wss:" then "wss://" else "ws://") ++ + maybe "" (\auth -> + -- Remove default ports + let hostPort = uriRegName auth ++ + case uriPort auth of + ":80" | uriScheme uri' == "ws:" -> "" + ":443" | uriScheme uri' == "wss:" -> "" + p -> p + in hostPort + ) (uriAuthority uri') ++ + -- Remove trailing slash + dropWhileEnd (== '/') (uriPath uri' ++ uriQuery uri' ++ uriFragment uri') + Nothing -> uri -- If parsing fails, return original URI + + +-- | Normalize a Relay by normalizing its URI +normalizeRelay :: Relay -> Relay +normalizeRelay relay = case relay of + InboxRelay uri -> InboxRelay (normalizeRelayURI uri) + OutboxRelay uri -> OutboxRelay (normalizeRelayURI uri) + InboxOutboxRelay uri -> InboxOutboxRelay (normalizeRelayURI uri) diff --git a/src/Types.hs b/src/Types.hs index 0c34ab0..42c5c7a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -7,37 +7,124 @@ import Effectful.Concurrent.STM (TChan, TQueue) import Graphics.QML (ObjRef) import Nostr.Keys (KeyPair, PubKeyXO) -import Nostr.Types (Event, EventId, Profile, RelayInfo, RelayURI, Request, Response, SubscriptionId) +import Nostr.Types (Event, EventId, Filter, Profile, Relay, RelayURI, Request, SubscriptionId) + + +-- | UI updates +data UIUpdates = UIUpdates + { profilesChanged :: Bool + , followsChanged :: Bool + , chatsChanged :: Bool + , dmRelaysChanged :: Bool + , generalRelaysChanged :: Bool + , publishStatusChanged :: Bool + , noticesChanged :: Bool + } deriving (Eq, Show) + + +instance Semigroup UIUpdates where + a <> b = UIUpdates + { profilesChanged = profilesChanged a || profilesChanged b + , followsChanged = followsChanged a || followsChanged b + , chatsChanged = chatsChanged a || chatsChanged b + , dmRelaysChanged = dmRelaysChanged a || dmRelaysChanged b + , generalRelaysChanged = generalRelaysChanged a || generalRelaysChanged b + , publishStatusChanged = publishStatusChanged a || publishStatusChanged b + , noticesChanged = noticesChanged a || noticesChanged b + } + + +instance Monoid UIUpdates where + mempty = emptyUpdates + + +-- | Empty UI updates. +emptyUpdates :: UIUpdates +emptyUpdates = UIUpdates False False False False False False False + + +-- | Status of a publish operation +data PublishStatus + = Publishing + | WaitingForConfirmation + | Success + | Failure Text + deriving (Eq, Show) + + +-- | Subscription events +data SubscriptionEvent + = EventAppeared Event + | SubscriptionEose + | SubscriptionClosed Text + -- | State for RelayPool handling. data RelayPoolState = RelayPoolState - { relays :: Map RelayURI RelayData + { activeConnections :: Map RelayURI RelayData + , publishStatus :: Map EventId (Map RelayURI PublishStatus) + , generalRelays :: Map PubKeyXO ([Relay], Int) + , dmRelays :: Map PubKeyXO ([Relay], Int) } +-- | Subscription details. +data SubscriptionDetails = SubscriptionDetails + { subscriptionId :: SubscriptionId + , subscriptionFilters :: [Filter] + , responseQueue :: TQueue SubscriptionEvent + , eventsProcessed :: Int + , newestCreatedAt :: Int + } + + +-- | Connection errors. +data ConnectionError + = ConnectionFailed Text + | AuthenticationFailed Text + | NetworkError Text + | TimeoutError + | InvalidRelayConfig + | MaxRetriesReached + | UserDisconnected + deriving (Show, Eq) + + +-- | Relay connection state. +data ConnectionState = Connected | Disconnected | Connecting + deriving (Show, Eq) + + -- | Data for each relay. data RelayData = RelayData - { relayInfo :: RelayInfo + { connectionState :: ConnectionState , requestChannel :: TChan Request - , responseQueue :: TQueue Response + , activeSubscriptions :: Map SubscriptionId SubscriptionDetails , notices :: [Text] - , subscriptions :: [SubscriptionId] + , lastError :: Maybe ConnectionError + , connectionAttempts :: Int + , authenticated :: Bool } -- | Initial state for RelayPool. initialRelayPoolState :: RelayPoolState initialRelayPoolState = RelayPoolState - { relays = Map.empty + { activeConnections = Map.empty + , publishStatus = Map.empty + , generalRelays = Map.empty + , dmRelays = Map.empty } +-- | Application screens data AppScreen = KeyMgmt | Home deriving (Eq, Read, Show) +-- | Chat message. data ChatMessage = ChatMessage { chatMessageId :: EventId , chatMessage :: Text @@ -47,55 +134,50 @@ data ChatMessage = ChatMessage } deriving (Show) -data EventConfirmation = EventConfirmation - { relay :: RelayURI - , waitingForConfirmation :: Bool - , accepted :: Bool - , message :: Text - } - - +-- | Application state. data AppState = AppState { keyPair :: Maybe KeyPair , currentScreen :: AppScreen - , events :: Map EventId (Event, [RelayURI]) + -- Relay management + , activeConnectionsCount :: Int + -- Data storage + , events :: Map EventId (Event, [Relay]) , chats :: Map [PubKeyXO] [ChatMessage] , profiles :: Map PubKeyXO (Profile, Int) - , follows :: FollowModel - , confirmations :: Map EventId [EventConfirmation] + , follows :: Map PubKeyXO [Follow] + -- UI state , currentChatRecipient :: (Maybe [PubKeyXO], Maybe SubscriptionId) , currentProfile :: Maybe PubKeyXO - , profileObjRef :: Maybe (ObjRef ()) - , chatObjRef :: Maybe (ObjRef ()) - , activeConnections :: Int } - -data FollowModel = FollowModel - { followList :: Map PubKeyXO [Follow] - , objRef :: Maybe (ObjRef ()) +-- | UI object references grouped together +data UIReferences = UIReferences + { profileObjRef :: Maybe (ObjRef ()) + , followsObjRef :: Maybe (ObjRef ()) + , chatObjRef :: Maybe (ObjRef ()) + , dmRelaysObjRef :: Maybe (ObjRef ()) + , generalRelaysObjRef :: Maybe (ObjRef ()) } +-- | Follow. data Follow = Follow { pubkey :: PubKeyXO - , relayURI :: Maybe RelayURI + , followRelay :: Maybe Relay , petName :: Maybe Text } deriving (Show) +-- | Initial application state. initialState :: AppState initialState = AppState { keyPair = Nothing , currentScreen = KeyMgmt + , activeConnectionsCount = 0 , events = Map.empty , chats = Map.empty , profiles = Map.empty - , follows = FollowModel Map.empty Nothing - , confirmations = Map.empty + , follows = Map.empty , currentChatRecipient = (Nothing, Nothing) , currentProfile = Nothing - , profileObjRef = Nothing - , chatObjRef = Nothing - , activeConnections = 0 } diff --git a/src/UI.hs b/src/UI.hs index 3827f3d..cf6da38 100644 --- a/src/UI.hs +++ b/src/UI.hs @@ -23,11 +23,12 @@ import Text.Read (readMaybe) import Logging import Nostr.Bech32 import Nostr.Event -import Nostr.RelayPool +import Nostr.Publisher import Nostr.Keys (PubKeyXO, keyPairToPubKeyXO) -import Nostr.Types (EventId(..), Profile(..), emptyProfile, relayURIToText) +import Nostr.Types (EventId(..), Profile(..), emptyProfile, getUri) import Nostr.Util import Presentation.KeyMgmt qualified as PKeyMgmt +import Presentation.RelayMgmt qualified as PRelayMgmt import Futr ( Futr, FutrEff, LoginStatusChanged, login, logout, followProfile, openChat, search, sendMessage, setCurrentProfile, unfollowProfile ) import Types @@ -49,6 +50,7 @@ runUI :: (FutrEff es, Futr :> es) => Eff (UI : es) a -> Eff es a runUI = interpret $ \_ -> \case CreateUI changeKey' -> withEffToIO (ConcUnlift Persistent Unlimited) $ \runE -> do keyMgmtObj <- runE $ PKeyMgmt.createUI changeKey' + relayMgmtObj <- runE $ PRelayMgmt.createUI changeKey' profileClass <- newClass [ defPropertySigRO' "name" changeKey' $ \_ -> do @@ -93,7 +95,7 @@ runUI = interpret $ \_ -> \case let profilePubKey = currentProfile st case (currentPubKey, profilePubKey) of (Just userPK, Just profilePK) -> do - let userFollows = Map.findWithDefault [] userPK (followList $ follows st) + let userFollows = Map.findWithDefault [] userPK (follows st) return $ any (\follow -> pubkey follow == profilePK) userFollows _ -> return False ] @@ -101,7 +103,7 @@ runUI = interpret $ \_ -> \case let followProp name' accessor = defPropertySigRO' name' changeKey' $ \obj -> do let pubKeyXO = fromObjRef obj :: PubKeyXO st <- runE $ get @AppState - let followList' = followList $ follows st + let followList' = follows st let userPubKey = keyPairToPubKeyXO <$> keyPair st let followData = userPubKey >>= \upk -> Map.lookup upk followList' >>= find (\f -> pubkey f == pubKeyXO) return $ accessor st followData @@ -110,7 +112,7 @@ runUI = interpret $ \_ -> \case followProp "pubkey" $ \_ followMaybe -> maybe "" (pubKeyXOToBech32 . pubkey) followMaybe, followProp "relay" $ \_ followMaybe -> - maybe "" (maybe "" relayURIToText . relayURI) followMaybe, + maybe "" (\f -> maybe "" getUri (followRelay f)) followMaybe, followProp "petname" $ \_ followMaybe -> maybe "" (fromMaybe "" . petName) followMaybe, followProp "displayName" $ \st followMaybe -> @@ -179,9 +181,11 @@ runUI = interpret $ \_ -> \case rootClass <- newClass [ defPropertyConst' "ctxKeyMgmt" (\_ -> return keyMgmtObj), + defPropertyConst' "ctxRelayMgmt" (\_ -> return relayMgmtObj), + defPropertyConst' "currentProfile" (\_ -> do profileObj <- newObject profileClass () - runE $ modify @AppState $ \st -> st { profileObjRef = Just profileObj } + runE $ modify @EffectfulQMLState $ \st -> st { uiRefs = (uiRefs st) { profileObjRef = Just profileObj } } return profileObj ), @@ -226,37 +230,36 @@ runUI = interpret $ \_ -> \case defMethod' "saveProfile" $ \_ input -> do let profile = maybe (error "Invalid profile JSON") id $ decode (BSL.fromStrict $ TE.encodeUtf8 input) :: Profile - st <- runE $ get @AppState n <- runE getCurrentTime - let kp = maybe (error "No key pair available") id $ keyPair st + kp <- runE getKeyPair let unsigned = createMetadata profile (keyPairToPubKeyXO kp) n signedMaybe <- signEvent unsigned kp case signedMaybe of Just signed -> do - st' <- runE $ get @RelayPoolState - runE $ sendEvent signed $ Map.keys (relays st') + runE $ broadcast signed runE $ logInfo "Profile successfully saved and sent to relay pool" Nothing -> runE $ logWarning "Failed to sign profile update event", defPropertySigRO' "follows" changeKey' $ \obj -> do + runE $ modify $ \s -> s { uiRefs = (uiRefs s) { followsObjRef = Just obj } } st <- runE $ get @AppState let maybeUserPubKey = keyPairToPubKeyXO <$> keyPair st case maybeUserPubKey of Just userPubKey -> do - let userFollows = Map.findWithDefault [] userPubKey (followList $ follows st) + let userFollows = Map.findWithDefault [] userPubKey (follows st) + runE $ logDebug $ "User follows: " <> pack (show userFollows) objs <- mapM (getPoolObject followPool) (map pubkey userFollows) - runE $ modify $ \s -> s { follows = (follows s) { objRef = Just obj } } return objs Nothing -> return [], defPropertySigRO' "messages" changeKey' $ \obj -> do + runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { chatObjRef = Just obj } } st <- runE $ get @AppState case currentChatRecipient st of (Just recipient, _) -> do let chatMessages = Map.findWithDefault [] recipient (chats st) let sortedChatMessages = sortOn (\msg -> chatMessageCreatedAt msg) chatMessages objs <- mapM (getPoolObject chatPool) (map chatMessageId sortedChatMessages) - runE $ modify @AppState $ \s -> s { chatObjRef = Just obj } return objs _ -> do runE $ logDebug $ "No current chat recipient"