diff --git a/src/EffectfulQML.hs b/src/EffectfulQML.hs index 1d268e2..ebb9c1e 100644 --- a/src/EffectfulQML.hs +++ b/src/EffectfulQML.hs @@ -34,7 +34,7 @@ initialEffectfulQMLState = EffectfulQMLState Nothing Nothing initialUIRefs Nothi -- | Initial UI references. initialUIRefs :: UIReferences -initialUIRefs = UIReferences Nothing Nothing Nothing Nothing Nothing +initialUIRefs = UIReferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing -- | Define the effects for QML operations. @@ -67,14 +67,21 @@ runEffectfulQML = interpret $ \_ -> \case let combinedUpdates = uiUpdates <> mconcat moreUpdates refs <- gets uiRefs - - when (profilesChanged combinedUpdates) $ forM_ (profileObjRef refs) (liftIO . QML.fireSignal changeKey) - when (followsChanged combinedUpdates) $ forM_ (followsObjRef refs) (liftIO . QML.fireSignal changeKey) - when (chatsChanged combinedUpdates) $ forM_ (chatObjRef refs) (liftIO . QML.fireSignal changeKey) - when (dmRelaysChanged combinedUpdates) $ forM_ (dmRelaysObjRef refs) (liftIO . QML.fireSignal changeKey) - when (generalRelaysChanged combinedUpdates) $ forM_ (generalRelaysObjRef refs) (liftIO . QML.fireSignal changeKey) - - threadDelay 100000 -- max 10 UI updates per second + -- Define update checks and their corresponding refs + let updates = [ (profilesChanged, profileObjRef) + , (followsChanged, followsObjRef) + , (postsChanged, postsObjRef) + , (privateMessagesChanged, privateMessagesObjRef) + , (dmRelaysChanged, dmRelaysObjRef) + , (generalRelaysChanged, generalRelaysObjRef) + , (tempRelaysChanged, tempRelaysObjRef) + ] + + forM_ updates $ \(checkFn, getRef) -> + when (checkFn combinedUpdates) $ + forM_ (getRef refs) (liftIO . QML.fireSignal changeKey) + + threadDelay 200000 -- 0.2 second delay for UI updates liftIO $ QML.runEngineLoop config @@ -90,7 +97,7 @@ runEffectfulQML = interpret $ \_ -> \case st <- get case queue st of Just q -> do - let updates = emptyUpdates { dmRelaysChanged = True, generalRelaysChanged = True } + let updates = emptyUpdates { dmRelaysChanged = True, generalRelaysChanged = True, tempRelaysChanged = True } atomically $ writeTQueue q updates Nothing -> logError "No queue available" diff --git a/src/Futr.hs b/src/Futr.hs index 8a30418..071be3d 100644 --- a/src/Futr.hs +++ b/src/Futr.hs @@ -6,10 +6,11 @@ module Futr where 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 +import Data.Maybe (catMaybes, fromMaybe, listToMaybe) import Data.Proxy (Proxy(..)) -import Data.Text (Text, isPrefixOf) +import Data.Set qualified as Set +import Data.Text (Text, isPrefixOf, pack) import Data.Typeable (Typeable) import Effectful import Effectful.Concurrent @@ -27,18 +28,18 @@ import Logging import KeyMgmt (Account(..), AccountId(..), KeyMgmt, KeyMgmtState(..)) import Nostr import Nostr.Bech32 -import Nostr.Event (createFollowList, createRumor) +import Nostr.Event (createComment, createFollowList, createQuoteRepost, createRepost, createRumor, createShortTextNote) import Nostr.Keys (PubKeyXO, derivePublicKeyXO, keyPairToPubKeyXO, secKeyToKeyPair) import Nostr.GiftWrap import Nostr.Publisher import Nostr.RelayPool import Nostr.Subscription -import Nostr.Types ( Relay(..), RelayURI, Tag(..) +import Nostr.Types ( Event(..), EventId, Profile(..), Relay(..), RelayURI, Tag(..) , getUri, metadataFilter ) import Nostr.Util import Presentation.KeyMgmtUI (KeyMgmtUI) import Presentation.RelayMgmtUI (RelayMgmtUI) -import Types +import Types hiding (Comment, QuoteRepost, Repost) -- | Signal key class for LoginStatusChanged. data LoginStatusChanged deriving Typeable @@ -70,7 +71,11 @@ data Futr :: Effect where UnfollowProfile :: Text -> Futr m () OpenChat :: PubKeyXO -> Futr m () SendMessage :: Text -> Futr m () + SendShortTextNote :: Text -> Futr m () Logout :: ObjRef () -> Futr m () + Repost :: EventId -> Futr m () + QuoteRepost :: EventId -> Text -> Futr m () + Comment :: EventId -> Text -> Futr m () -- | Dispatch type for Futr effect. @@ -167,27 +172,27 @@ runFutr = interpret $ \_ -> \case OpenChat pubKeyXO -> do st <- get @AppState - case currentChatRecipient st of + case currentContact st of (Just _, Just subId') -> stopSubscription subId' _ -> return () - modify $ \st' -> st' { currentChatRecipient = (Just [pubKeyXO], Nothing) } - notify $ emptyUpdates { chatsChanged = True } + modify $ \st' -> st' { currentContact = (Just pubKeyXO, Nothing) } + notify $ emptyUpdates { privateMessagesChanged = True } SendMessage input -> do st <- get @AppState - case (keyPair st, currentChatRecipient st) of - (Just kp, (Just recipients, _)) -> do + case (keyPair st, currentContact st) of + (Just kp, (Just recipient, _)) -> do now <- getCurrentTime let senderPubKeyXO = keyPairToPubKeyXO kp - allRecipients = senderPubKeyXO : recipients - rumor = createRumor senderPubKeyXO now (map (\xo -> PTag xo Nothing Nothing) recipients) input + allRecipients = senderPubKeyXO : recipient : [] + rumor = createRumor senderPubKeyXO now (map (\xo -> PTag xo Nothing Nothing) [recipient]) input - giftWraps <- forM allRecipients $ \recipient -> do - seal <- createSeal rumor kp recipient + giftWraps <- forM allRecipients $ \recipient' -> do + seal <- createSeal rumor kp recipient' case seal of Just seal' -> do - giftWrapResult <- createGiftWrap seal' recipient + giftWrapResult <- createGiftWrap seal' recipient' case giftWrapResult of Just (gw, _) -> return (Just gw) Nothing -> logError "Failed to create gift wrap" >> return Nothing @@ -199,6 +204,15 @@ runFutr = interpret $ \_ -> \case (Nothing, _) -> logError "No key pair found" (_, (Nothing, _)) -> logError "No current chat recipient" + SendShortTextNote input -> do + kp <- getKeyPair + now <- getCurrentTime + let u = createShortTextNote input (keyPairToPubKeyXO kp) now + signed <- signEvent u kp + case signed of + Just s -> publishToOutbox s + Nothing -> logError "Failed to sign short text note" + Logout obj -> do modify @AppState $ \st -> st { keyPair = Nothing @@ -218,6 +232,99 @@ runFutr = interpret $ \_ -> \case fireSignal obj logInfo "User logged out successfully" + Repost eid -> do + st <- get @AppState + case keyPair st of + Nothing -> logError "No keypair found" + Just kp -> do + now <- getCurrentTime + mEvent <- fetchEvent eid + case mEvent of + Nothing -> logError $ "Failed to fetch event " <> pack (show eid) + Just (_, []) -> do + logError "Failed to fetch event: no relays" + Just (event, r:_) -> do + let e = createRepost event r (keyPairToPubKeyXO kp) now + signed <- signEvent e kp + case signed of + Just s -> do + publishToOutbox s + case Map.lookup eid (events st) of + Just (origEvent, relays) -> do + genRelays <- gets @RelayPoolState generalRelays + let outboxUris = Set.fromList $ map getUri $ + filter isOutboxCapable $ concatMap fst $ Map.elems genRelays + + let eventRelayUris = Set.fromList relays + rps <- gets @RelayPoolState generalRelays + let authorInboxUris = case Map.lookup (pubKey origEvent) rps of + Just (authorRelays, _) -> + Set.fromList $ map getUri $ filter isInboxCapable authorRelays + Nothing -> Set.empty + + let targetUris = (eventRelayUris `Set.union` authorInboxUris) + `Set.difference` outboxUris + + forM_ (Set.toList targetUris) $ \relay -> + publishToRelay s relay + Nothing -> return () + Nothing -> logError "Failed to sign repost" + + QuoteRepost eid quote -> do + st <- get @AppState + case keyPair st of + Nothing -> logError "No keypair found" + Just kp -> do + now <- getCurrentTime + mEvent <- fetchEvent eid + case mEvent of + Nothing -> logError $ "Failed to fetch event " <> pack (show eid) + Just (_, []) -> do + logError "Failed to fetch event: no relays" + Just (event, r:_) -> do + let q = createQuoteRepost event r quote (keyPairToPubKeyXO kp) now + signed <- signEvent q kp + case signed of + Just s -> publishToOutbox s + Nothing -> logError "Failed to sign quote repost" + + Comment eid comment -> do + st <- get @AppState + case keyPair st of + Nothing -> logError "No keypair found" + Just kp -> do + now <- getCurrentTime + mEvent <- fetchEvent eid + case mEvent of + Nothing -> logError $ "Failed to fetch event " <> pack (show eid) + Just (event, _) -> do + let c = createComment event comment (Right eid) Nothing Nothing (keyPairToPubKeyXO kp) now + signed <- signEvent c kp + case signed of + Just s -> do + publishToOutbox s + -- Publish to relays where the original event was seen + case Map.lookup eid (events st) of + Just (origEvent, relays) -> do + -- Publish to all relays where we saw the original event + forM_ relays $ \relay -> publishToRelay s relay + -- Also publish to inbox relays of the original author + let authorPk = pubKey origEvent + rps <- gets @RelayPoolState generalRelays + case Map.lookup authorPk rps of + Just (authorRelays, _) -> + forM_ (filter isInboxCapable authorRelays) $ \relay -> + publishToRelay s (getUri relay) + Nothing -> return () + Nothing -> return () + Nothing -> logError "Failed to sign comment" + + +-- Helper function to fetch an event +fetchEvent :: EventId -> FutrEff es => Eff es (Maybe (Event, [RelayURI])) +fetchEvent eid = do + es <- gets @AppState events + return $ Map.lookup eid es -- Helper function to parse nprofile or npub parseNprofileOrNpub :: Text -> Maybe (PubKeyXO, Maybe RelayURI) @@ -287,9 +394,9 @@ searchInRelays pubkey' _ = do Just (rs, _) -> rs Nothing -> [] conns <- gets @RelayPoolState activeConnections - forM_ relays $ \r -> do - when (isInboxCapable r) $ do - let relayUri' = getUri r + forM_ relays $ \relay -> do + when (isInboxCapable relay) $ do + let relayUri' = getUri relay when (Map.member relayUri' conns) $ do subId' <- newSubscriptionId mq <- subscribe relayUri' subId' [metadataFilter [pubkey']] @@ -314,3 +421,61 @@ isInboxCapable :: Relay -> Bool isInboxCapable (InboxRelay _) = True isInboxCapable (InboxOutboxRelay _) = True isInboxCapable _ = False + + +-- | Get the content of a post. +getPostContent :: FutrEff es => Post -> Eff es (Maybe Text) +getPostContent post = do + st <- get @AppState + return $ Map.lookup (postId post) (events st) >>= Just . content . fst + +-- | Get the creation timestamp of a post. +getPostCreatedAt :: FutrEff es => Post -> Eff es (Maybe Int) +getPostCreatedAt post = do + st <- get @AppState + return $ Map.lookup (postId post) (events st) >>= Just . createdAt . fst + + +-- | Get the content of a referenced post. +getReferencedContent :: FutrEff es => EventId -> Eff es (Maybe Text) +getReferencedContent eid = do + st <- get @AppState + return $ Map.lookup eid (events st) >>= Just . content . fst + +-- | Get the author of a referenced post. +getReferencedAuthor :: FutrEff es => EventId -> Eff es (Maybe PubKeyXO) +getReferencedAuthor eid = do + st <- get @AppState + return $ Map.lookup eid (events st) >>= Just . pubKey . fst + + +-- | Get the author name of a referenced post. +getReferencedAuthorName :: FutrEff es => EventId -> Eff es (Maybe Text) +getReferencedAuthorName eid = do + st <- get @AppState + case Map.lookup eid (events st) of + Nothing -> return Nothing + Just (event, _) -> do + let authorPubKey = pubKey event + authorProfile = Map.lookup authorPubKey (profiles st) + return $ case authorProfile of + Just profileData -> Just $ fromMaybe + (fromMaybe (pubKeyXOToBech32 authorPubKey) (name $ fst profileData)) + (displayName $ fst profileData) + Nothing -> Just $ pubKeyXOToBech32 authorPubKey + +-- | Get the author picture of a referenced post. +getReferencedAuthorPicture :: FutrEff es => EventId -> Eff es (Maybe Text) +getReferencedAuthorPicture eid = do + st <- get @AppState + case Map.lookup eid (events st) of + Nothing -> return Nothing + Just (event, _) -> do + let authorPubKey = pubKey event + return $ Map.lookup authorPubKey (profiles st) >>= picture . fst + +-- | Get the creation timestamp of a referenced post. +getReferencedCreatedAt :: FutrEff es => EventId -> Eff es (Maybe Int) +getReferencedCreatedAt eid = do + st <- get @AppState + return $ Map.lookup eid (events st) >>= Just . createdAt . fst diff --git a/src/Nostr/Event.hs b/src/Nostr/Event.hs index 8cce4e4..5767517 100755 --- a/src/Nostr/Event.hs +++ b/src/Nostr/Event.hs @@ -6,18 +6,18 @@ module Nostr.Event where import Crypto.Hash.SHA256 qualified as SHA256 +import Crypto.Random (getRandomBytes) import Data.Aeson import Data.ByteString.Lazy (fromStrict, toStrict) -import Data.Text (Text) +import Data.Text (Text, pack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time.Clock.POSIX (getCurrentTime, utcTimeToPOSIXSeconds) +import System.Random (randomRIO) - +import Nostr.Bech32 (eventToNevent) import Nostr.Keys 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. @@ -60,6 +60,100 @@ validateEvent :: Event -> Bool validateEvent e = validateEventId e && verifySignature e +-- | Create a comment event (NIP-22) for text notes. +createComment :: Event -- ^ Original event being commented on + -> Text -- ^ Comment content + -> Either Tag EventId -- ^ Root scope (Tag for I-tags, EventId for events) + -> Maybe Tag -- ^ Optional parent item (for replies) + -> Maybe RelayURI -- ^ Optional relay hint + -> PubKeyXO -- ^ Author's public key + -> Int -- ^ Timestamp + -> UnsignedEvent +createComment originalEvent content' rootScope parentItem relayHint xo t = + UnsignedEvent + { pubKey' = xo + , createdAt' = t + , kind' = Comment + , tags' = buildTags rootScope parentItem relayHint + , content' = content' + } + where + buildTags :: Either Tag EventId -> Maybe Tag -> Maybe RelayURI -> [Tag] + buildTags root parent relay = + let + -- Root scope tags + rootTags = case root of + Left (ITag val _) -> + [ ITag val relay + , KTag (pack $ show $ kind originalEvent) + ] + Right eid -> + [ ETag eid relay Nothing + , KTag (pack $ show $ kind originalEvent) + ] + _ -> error "Invalid root scope tag" + + -- Parent tags (for replies) + parentTags = case parent of + Just (ETag eid _ mpk) -> + [ ETag eid relay mpk + , KTag (pack $ show Comment) + ] + Just (ITag val _) -> + [ ITag val relay + , KTag (pack $ show $ kind originalEvent) + ] + Nothing -> case root of + Left itag@(ITag _ _) -> [itag, KTag (pack $ show Comment)] + Right eid -> [ETag eid relay Nothing, KTag (pack $ show Comment)] + _ -> [] + _ -> error "Invalid parent tag" + in + rootTags ++ parentTags + + +-- | Create a repost event (kind 6) for text notes. +createRepost :: Event -> RelayURI -> PubKeyXO -> Int -> UnsignedEvent +createRepost event relayUrl xo t = + UnsignedEvent + { pubKey' = xo + , createdAt' = t + , kind' = Repost + , tags' = [ ETag (eventId event) (Just relayUrl) Nothing + , PTag (pubKey event) Nothing Nothing + ] + , content' = decodeUtf8 $ toStrict $ encode event + } + + +-- | Create a quote repost event (kind 1 with q tag). +createQuoteRepost :: Event -> RelayURI -> Text -> PubKeyXO -> Int -> UnsignedEvent +createQuoteRepost event relayUrl quote xo t = + UnsignedEvent + { pubKey' = xo + , createdAt' = t + , kind' = ShortTextNote + , tags' = [ QTag (eventId event) (Just relayUrl) (Just $ pubKey event) + ] + , content' = quote <> "\n\nnostr:" <> eventToNevent event (Just relayUrl) + } + + +-- | Create a generic repost event (kind 16) for non-text-note events. +createGenericRepost :: Event -> RelayURI -> PubKeyXO -> Int -> UnsignedEvent +createGenericRepost event relayUrl xo t = + UnsignedEvent + { pubKey' = xo + , createdAt' = t + , kind' = GenericRepost + , tags' = [ ETag (eventId event) (Just relayUrl) Nothing + , PTag (pubKey event) Nothing Nothing + , KTag (pack $ show $ kind event) + ] + , content' = decodeUtf8 $ toStrict $ encode event + } + + -- | Create a short text note event. createShortTextNote :: Text -> PubKeyXO -> Int -> UnsignedEvent createShortTextNote note xo t = diff --git a/src/Nostr/GiftWrap.hs b/src/Nostr/GiftWrap.hs index 9c1bfcd..817d10c 100644 --- a/src/Nostr/GiftWrap.hs +++ b/src/Nostr/GiftWrap.hs @@ -12,15 +12,14 @@ import Effectful.TH (makeEffect) import Data.List (sort) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) -import Data.Text (pack) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Time.Format (defaultTimeLocale, formatTime) import Logging import Nostr import Nostr.Event (validateEvent) import Nostr.Keys (KeyPair, PubKeyXO, byteStringToHex, keyPairToPubKeyXO) import Nostr.Types (Event(..), EventId(..), Kind(..), Rumor(..), Tag(..)) +import Nostr.Util (Util, getCurrentTime) +import TimeFormatter (Language(..), formatDateTime) import Types (AppState(..),ChatMessage(..)) -- | GiftWrap Effects. @@ -36,9 +35,10 @@ makeEffect ''GiftWrap -- | Effectful type for GiftWrap. type GiftWrapEff es = ( State AppState :> es + , Nostr :> es + , Util :> es , Logging :> es , IOE :> es - , Nostr :> es ) @@ -82,13 +82,16 @@ processDecryptedRumor decryptedRumor sealedEvent originalEvent kp then sort $ getAllPTags (rumorTags decryptedRumor) else filter (/= keyPairToPubKeyXO kp) $ rumorPubKey decryptedRumor : sort (getAllPTags (rumorTags decryptedRumor)) let senderPubKey = rumorPubKey decryptedRumor - let chatMsg = createChatMessage originalEvent decryptedRumor senderPubKey - updateChats chatKey chatMsg + ct <- getCurrentTime + updateChats chatKey $ createChatMessage originalEvent decryptedRumor senderPubKey ct -- | Update chats. updateChats :: State AppState :> es => [PubKeyXO] -> ChatMessage -> Eff es () -updateChats chatKey chatMsg = do +updateChats chatKeys chatMsg = do + let chatKey = case chatKeys of + (k:_) -> k + [] -> error "Empty chat key list" modify $ \s -> s { chats = mergeMessageIntoChats chatKey chatMsg (chats s) } @@ -101,19 +104,19 @@ getAllPTags = mapMaybe extractPubKey -- | Create a chat message. -createChatMessage :: Event -> Rumor -> PubKeyXO -> ChatMessage -createChatMessage originalEvent decryptedRumor senderPubKey = +createChatMessage :: Event -> Rumor -> PubKeyXO -> Int -> ChatMessage +createChatMessage originalEvent decryptedRumor senderPubKey currentTimestamp = ChatMessage { chatMessageId = eventId originalEvent , chatMessage = rumorContent decryptedRumor , author = senderPubKey , chatMessageCreatedAt = rumorCreatedAt decryptedRumor - , timestamp = pack $ formatTime defaultTimeLocale "%FT%T%QZ" $ posixSecondsToUTCTime $ fromIntegral $ rumorCreatedAt decryptedRumor + , timestamp = formatDateTime English currentTimestamp (rumorCreatedAt decryptedRumor) } -- | Merge a new chat message into the existing chat map -mergeMessageIntoChats :: [PubKeyXO] -> ChatMessage -> Map.Map [PubKeyXO] [ChatMessage] -> Map.Map [PubKeyXO] [ChatMessage] +mergeMessageIntoChats :: PubKeyXO -> ChatMessage -> Map.Map PubKeyXO [ChatMessage] -> Map.Map PubKeyXO [ChatMessage] mergeMessageIntoChats chatKey chatMsg = Map.alter (addOrUpdateChatThread chatMsg) chatKey diff --git a/src/Nostr/RelayConnection.hs b/src/Nostr/RelayConnection.hs index 1871259..c7357bb 100644 --- a/src/Nostr/RelayConnection.hs +++ b/src/Nostr/RelayConnection.hs @@ -6,7 +6,7 @@ import Control.Exception (SomeException, try) import Control.Monad (forM_,void, when) import Data.Aeson (eitherDecode, encode) import Data.ByteString.Lazy qualified as BSL -import Data.List (find) +import Data.List (dropWhileEnd, find) import Data.Map.Strict qualified as Map import Data.Text qualified as T import Effectful @@ -18,6 +18,7 @@ import Effectful.Concurrent.STM ( TChan, TMVar, atomically, newTChanIO, newTQueu 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 Network.WebSockets qualified as WS import Wuss qualified as Wuss @@ -73,23 +74,24 @@ runRelayConnection -> Eff es a runRelayConnection = interpret $ \_ -> \case ConnectRelay r -> do + let r' = normalizeRelayURI r conns <- gets @RelayPoolState activeConnections - if Map.member r conns + if Map.member r' conns then do - let connState = connectionState <$> Map.lookup r conns + let connState = connectionState <$> Map.lookup r' conns case connState of Just Connected -> do - logDebug $ "Already connected to " <> r + logDebug $ "Already connected to " <> r' return True Just Connecting -> do - logDebug $ "Connection already in progress for " <> r + logDebug $ "Connection already in progress for " <> r' return False Just Disconnected -> do -- Try to reconnect chan <- newTChanIO - connectWithRetry r 5 chan + connectWithRetry r' 5 chan Nothing -> do - logWarning $ "No connection state found for relay: " <> r + logWarning $ "No connection state found for relay: " <> r' return False else do chan <- newTChanIO @@ -105,16 +107,17 @@ runRelayConnection = interpret $ \_ -> \case , pendingAuthId = Nothing } modify @RelayPoolState $ \st -> - st { activeConnections = Map.insert r rd (activeConnections st) } - connectWithRetry r 5 chan + st { activeConnections = Map.insert r' rd (activeConnections st) } + connectWithRetry r' 5 chan DisconnectRelay r -> do + let r' = normalizeRelayURI r st <- get @RelayPoolState - case Map.lookup r (activeConnections st) of + 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') } + st' { activeConnections = Map.delete r' (activeConnections st') } Nothing -> return () @@ -386,3 +389,22 @@ handleAuthRequired relayURI' request = case request of relayURI' (activeConnections st') } + + +-- | Normalize a relay URI according to RFC 3986 +normalizeRelayURI :: RelayURI -> RelayURI +normalizeRelayURI uri = case parseURI (T.unpack uri) of + Just uri' -> T.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 diff --git a/src/Nostr/Subscription.hs b/src/Nostr/Subscription.hs index ec3e8ca..4080d9a 100644 --- a/src/Nostr/Subscription.hs +++ b/src/Nostr/Subscription.hs @@ -5,8 +5,10 @@ import Data.Aeson (eitherDecode) import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as B16 import Data.ByteString.Lazy (fromStrict) +import Data.List (nubBy, sortBy) import Data.Map.Strict qualified as Map -import Data.Text (pack, unpack) +import Data.Ord (comparing) +import Data.Text (pack, unpack, isInfixOf) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Effectful import Effectful.Concurrent @@ -18,6 +20,7 @@ import Effectful.TH import Network.URI (URI(..), parseURI, uriAuthority, uriRegName, uriScheme) import System.Random (randomIO) + import EffectfulQML import KeyMgmt (AccountId(..), KeyMgmt, updateProfile) import Logging @@ -31,7 +34,9 @@ import Nostr.Types ( Event(..), EventId(..), Filter, Kind(..), Relay(..) import Nostr.Types qualified as NT import Nostr.Util import RelayMgmt -import Types +import TimeFormatter (Language(..), formatDateTime) +import Types hiding (Repost, ShortTextNote) +import Types qualified as Types -- | Subscription effects @@ -85,19 +90,123 @@ runSubscription = interpret $ \_ -> \case } Nothing -> return () - HandleEvent _ _ _ event' -> handleEvent' event' + HandleEvent r _ _ event' -> handleEvent' event' r -handleEvent' :: SubscriptionEff es => Event -> Eff es UIUpdates -handleEvent' event' = do +handleEvent' :: SubscriptionEff es => Event -> RelayURI -> Eff es UIUpdates +handleEvent' event' r = do -- @todo validate event against filters ?? if not (validateEvent event') then do logWarning $ "Invalid event seen: " <> (byteStringToHex $ getEventId (eventId event')) pure emptyUpdates else do - logDebug $ "Handling event of kind " <> pack (show $ kind event') <> " with id " <> (byteStringToHex $ getEventId (eventId event')) + --logDebug $ "Handling event of kind " <> pack (show $ kind event') <> " with id " <> (byteStringToHex $ getEventId (eventId event')) + + -- store into our events map + modify @AppState $ \st -> + st { events = Map.insertWith + (\_ (oldEvent, oldRelays) -> (oldEvent, if r `elem` oldRelays then oldRelays else r:oldRelays)) + (eventId event') + (event', [r]) + (events st) + } + case kind event' of + ShortTextNote -> do + -- Check for q-tag to identify quote reposts + let qTags = [t | t@(QTag _ _ _) <- tags event'] + case qTags of + (QTag quotedId mRelay _:_) -> do + -- Verify content contains NIP-21 identifier + let contentText = content event' + hasNIP21 = "nostr:" `isInfixOf` contentText && + (any (`isInfixOf` contentText) ["note1", "nevent1", "naddr1"]) + + if hasNIP21 + then do + let note = Types.Post + { postId = eventId event' + , postType = Types.QuoteRepost quotedId + } + + modify @AppState $ \st -> + st { posts = Map.insertWith + (\new old -> sortBy (comparing (\p -> createdAt . fst . (events st Map.!) . postId $ p)) (new ++ old)) + (pubKey event') + [note] + (posts st) + } + + pure $ emptyUpdates { postsChanged = True } + else do + logWarning $ "Quote repost missing required NIP-21 identifier: " <> + (byteStringToHex $ getEventId (eventId event')) + pure emptyUpdates + + [] -> do + -- Regular short text note + let note = Types.Post + { postId = eventId event' + , postType = Types.ShortTextNote + } + + modify @AppState $ \st -> + st { posts = Map.insertWith + (\new old -> sortBy (comparing (\p -> createdAt . fst . (events st Map.!) . postId $ p)) (new ++ old)) + (pubKey event') + [note] + (posts st) + } + + pure $ emptyUpdates { postsChanged = True } + + Repost -> do + -- Check for ETag (required for reposts) + case [t | t@(ETag _ _ _) <- tags event'] of + (ETag eid mRelay _:_) -> do + case eitherDecode (fromStrict $ encodeUtf8 $ content event') of + Right originalEvent -> do + if validateEvent originalEvent + then do + modify @AppState $ \st -> + st { events = Map.insertWith + (\_ (oldEvent, oldRelays) -> + (oldEvent, maybe oldRelays (:oldRelays) mRelay)) + (eventId originalEvent) + (originalEvent, maybe [] (:[]) mRelay) + (events st) + } + + let note = Types.Post + { postId = eventId event' + , postType = Types.Repost eid + } + + modify @AppState $ \st -> + st { posts = Map.insertWith + (\new old -> sortBy (comparing (\p -> createdAt . fst . (events st Map.!) . postId $ p)) (new ++ old)) + (pubKey event') + [note] + (posts st) + } + + pure $ emptyUpdates { postsChanged = True } + else do + logWarning $ "Invalid original event in repost: " <> + (byteStringToHex $ getEventId (eventId event')) + pure emptyUpdates + Left err -> do + logWarning $ "Failed to decode original event in repost: " <> pack err + pure emptyUpdates + _ -> do + logWarning $ "Repost without e-tag ignored: " <> + (byteStringToHex $ getEventId (eventId event')) + pure emptyUpdates + + EventDeletion -> do + pure emptyUpdates + Metadata -> do case eitherDecode (fromStrict $ encodeUtf8 $ content event') of Right profile -> do @@ -126,7 +235,7 @@ handleEvent' event' = do GiftWrap -> do handleGiftWrapEvent event' - pure $ emptyUpdates { chatsChanged = True } + pure $ emptyUpdates { privateMessagesChanged = True } RelayListMetadata -> do logDebug $ pack $ show event' @@ -241,7 +350,7 @@ handleRelaySubscription r = do es <- atomically $ flushTQueue q updates <- fmap mconcat $ forM (e : es) $ \case - EventAppeared event' -> handleEvent' event' + EventAppeared event' -> handleEvent' event' r SubscriptionEose -> return emptyUpdates SubscriptionClosed _ -> do atomically $ writeTVar shouldStop True @@ -306,6 +415,7 @@ createInboxRelayFilters :: PubKeyXO -> [PubKeyXO] -> [Filter] createInboxRelayFilters xo followedPubKeys = [ NT.followListFilter (xo : followedPubKeys) , NT.metadataFilter (xo : followedPubKeys) + , NT.shortTextNoteFilter (xo : followedPubKeys) , NT.preferredDMRelaysFilter (xo : followedPubKeys) ] diff --git a/src/Nostr/Types.hs b/src/Nostr/Types.hs index 7160d22..2099f68 100644 --- a/src/Nostr/Types.hs +++ b/src/Nostr/Types.hs @@ -138,12 +138,14 @@ data Kind | EventDeletion -- NIP-09 (kind 5) | Repost -- NIP-18 (kind 6) | Reaction -- NIP-25 (kind 7) + | GenericRepost -- NIP-18 (kind 16) | 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) + | Comment -- NIP-22 (kind 1111) | UnknownKind Int deriving (Eq, Generic, Read, Show) @@ -153,7 +155,21 @@ newtype EventId = EventId { getEventId :: ByteString } deriving (Eq, Ord) -- | Represents a relationship type. -data Relationship = Reply | Root +data Relationship = Reply | Root | Mention + deriving (Eq, Generic, Show) + + +-- | Represents different types of external content IDs as specified in NIP-73 +data ExternalId + = UrlId Text -- ^ Normalized URL without fragment + | HashtagId Text -- ^ Lowercase hashtag + | GeohashId Text -- ^ Lowercase geohash + | IsbnId Text -- ^ ISBN without hyphens + | PodcastGuidId Text -- ^ Podcast GUID + | PodcastItemGuidId Text -- ^ Podcast Episode GUID + | PodcastPublisherGuidId Text -- ^ Podcast Publisher GUID + | IsanId Text -- ^ ISAN without version part + | DoiId Text -- ^ Lowercase DOI deriving (Eq, Generic, Show) @@ -161,8 +177,11 @@ data Relationship = Reply | Root data Tag = ETag EventId (Maybe RelayURI) (Maybe Relationship) | PTag PubKeyXO (Maybe RelayURI) (Maybe DisplayName) + | QTag EventId (Maybe RelayURI) (Maybe PubKeyXO) + | KTag Text | RelayTag Relay | ChallengeTag Text + | ITag ExternalId (Maybe Text) | GenericTag [Value] deriving (Eq, Generic, Show) @@ -273,6 +292,13 @@ instance Show EventId where showsPrec _ = shows . B16.encode . getEventId +-- | Reads an 'EventId' from its string representation. +instance Read EventId where + readsPrec _ str = case decodeHex str of + Just bs | BS.length bs == 32 -> [(EventId bs, "")] + _ -> [] + + -- | Converts a JSON string into an 'EventId'. instance FromJSON EventId where parseJSON = withText "EventId" $ \i -> do @@ -359,6 +385,9 @@ instance FromJSON Tag where case V.toList arr of ("e":rest) -> either (const $ parseGenericTag v) return $ parseEither (parseETag rest) v ("p":rest) -> parsePTag rest v + ("q":rest) -> parseQTag rest v + ("i":rest) -> parseITag rest v + ("k":rest) -> parseKTag rest v ("relay":rest) -> parseRelayTag rest v ("challenge":rest) -> parseChallengeTag rest v _ -> parseGenericTag v @@ -468,30 +497,47 @@ parseGenericTag v = fail $ "Expected array for generic tag, got: " ++ show v -- | Converts a 'Tag' to its JSON representation. instance ToJSON Tag where - toEncoding (ETag eventId relayURL marker) = - list id $ - [ text "e" - , text $ decodeUtf8 $ B16.encode $ getEventId eventId - ] ++ - (maybe [] (\r -> [text r]) relayURL) ++ - (case marker of - Just Reply -> [text "reply"] - Just Root -> [text "root"] - Nothing -> []) - toEncoding (PTag xo relayURL name) = - list id $ - [ text "p" - , toEncoding xo - ] ++ - (maybe [] (\r -> [text r]) relayURL) ++ - (maybe [] (\n -> [text n]) name) - 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 + toEncoding tag = case tag of + ETag eventId relayURL marker -> + list id $ + [ text "e" + , text $ decodeUtf8 $ B16.encode $ getEventId eventId + ] ++ + (maybe [] (\r -> [text r]) relayURL) ++ + (case marker of + Just Reply -> [text "reply"] + Just Root -> [text "root"] + Just Mention -> [text "mention"] + Nothing -> []) + PTag xo relayURL name -> + list id $ + [ text "p" + , toEncoding xo + ] ++ + (maybe [] (\r -> [text r]) relayURL) ++ + (maybe [] (\n -> [text n]) name) + QTag eventId relayURL pubkey -> + list id $ + [ text "q" + , text $ decodeUtf8 $ B16.encode $ getEventId eventId + ] ++ + (maybe [] (\r -> [text r]) relayURL) ++ + (maybe [] (\pk -> [text $ decodeUtf8 $ B16.encode $ exportPubKeyXO pk]) pubkey) + ITag eid urlHint -> + list id $ + [ text "i" + , text (externalIdToText eid) + ] ++ + maybe [] (\url -> [text url]) urlHint + KTag kind -> + list id [ text "k", text kind ] + 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] + ChallengeTag challenge -> list id [text "challenge", text challenge] + GenericTag values -> list toEncoding values -- | Converts a JSON string into a 'Relationship'. @@ -500,6 +546,7 @@ instance FromJSON Relationship where case T.toLower m of "reply" -> return Reply "root" -> return Root + "mention" -> return Mention _ -> mzero @@ -507,7 +554,7 @@ instance FromJSON Relationship where instance ToJSON Relationship where toEncoding Reply = text "reply" toEncoding Root = text "root" - + toEncoding Mention = text "mention" -- | Converts a JSON array into a 'Response'. instance FromJSON Response where @@ -565,12 +612,14 @@ instance FromJSON Kind where 5 -> return EventDeletion 6 -> return Repost 7 -> return Reaction + 16 -> return GenericRepost 13 -> return Seal 1059 -> return GiftWrap 14 -> return DirectMessage 10050 -> return PreferredDMRelays 22242 -> return CanonicalAuthentication 10002 -> return RelayListMetadata + 1111 -> return Comment _ -> return $ UnknownKind n Nothing -> fail "Expected an integer for Kind" @@ -583,6 +632,7 @@ instance ToJSON Kind where toEncoding FollowList = toEncoding (3 :: Int) toEncoding EventDeletion = toEncoding (5 :: Int) toEncoding Repost = toEncoding (6 :: Int) + toEncoding GenericRepost = toEncoding (16 :: Int) toEncoding Reaction = toEncoding (7 :: Int) toEncoding Seal = toEncoding (13 :: Int) toEncoding GiftWrap = toEncoding (1059 :: Int) @@ -590,6 +640,7 @@ instance ToJSON Kind where toEncoding PreferredDMRelays = toEncoding (10050 :: Int) toEncoding CanonicalAuthentication = toEncoding (22242 :: Int) toEncoding RelayListMetadata = toEncoding (10002 :: Int) + toEncoding Comment = toEncoding (1111 :: Int) toEncoding (UnknownKind n) = toEncoding n @@ -722,13 +773,13 @@ followListFilter authors = Filter -- | Creates a filter for short text notes. -shortTextNoteFilter :: [PubKeyXO] -> Int -> Filter -shortTextNoteFilter authors now = Filter +shortTextNoteFilter :: [PubKeyXO] -> Filter +shortTextNoteFilter authors = Filter { ids = Nothing , authors = Just authors - , kinds = Just [ShortTextNote, EventDeletion] + , kinds = Just [ShortTextNote, EventDeletion, Repost] , since = Nothing - , until = Just (now + 60) + , until = Nothing , limit = Just 500 , fTags = Nothing } @@ -771,3 +822,82 @@ eventFilter eid = Filter , limit = Nothing , fTags = Nothing } + +-- Add parser for QTag +parseQTag :: [Value] -> Value -> Parser Tag +parseQTag rest _ = case rest of + [eventIdVal, relayVal, pubkeyVal] -> do + eventId <- parseJSONSafe eventIdVal + relay <- parseMaybeRelayURI relayVal + pubkey <- case parseEither parseJSON pubkeyVal of + Right pk -> return (Just pk) + Left _ -> return Nothing + return $ QTag eventId relay pubkey + [eventIdVal, relayVal] -> do + eventId <- parseJSONSafe eventIdVal + relay <- parseMaybeRelayURI relayVal + return $ QTag eventId relay Nothing + [eventIdVal] -> do + eventId <- parseJSONSafe eventIdVal + return $ QTag eventId Nothing Nothing + _ -> fail "Invalid QTag format" + +-- Add parser for KTag +parseKTag :: [Value] -> Value -> Parser Tag +parseKTag rest _ = case rest of + [String kind] -> return $ KTag kind + _ -> fail "Invalid KTag format" + + +-- Add parser for ITag +parseITag :: [Value] -> Value -> Parser Tag +parseITag rest _ = case rest of + [String identifier, String urlHint] -> do + case parseExternalId identifier of + Just eid -> return $ ITag eid (Just urlHint) + Nothing -> fail $ "Invalid external identifier: " <> T.unpack identifier + [String identifier] -> do + case parseExternalId identifier of + Just eid -> return $ ITag eid Nothing + Nothing -> fail $ "Invalid external identifier: " <> T.unpack identifier + _ -> fail "Invalid ITag format" + + +-- | Parse an ExternalId from text +parseExternalId :: Text -> Maybe ExternalId +parseExternalId t = case T.splitOn ":" t of + ["isbn", isbn] -> Just $ IsbnId isbn + ["podcast", "guid", guid] -> Just $ PodcastGuidId guid + ["podcast", "item", "guid", guid] -> Just $ PodcastItemGuidId guid + ["podcast", "publisher", "guid", guid] -> Just $ PodcastPublisherGuidId guid + ["isan", isan] -> Just $ IsanId isan + ["geo", geohash] -> Just $ GeohashId geohash + ["doi", doi] -> Just $ DoiId (T.toLower doi) + [tag] | T.head tag == '#' -> Just $ HashtagId (T.toLower tag) + _ -> Nothing + + +-- | Convert ExternalId to text +externalIdToText :: ExternalId -> Text +externalIdToText = \case + UrlId url -> url + HashtagId tag -> tag + GeohashId hash -> "geo:" <> hash + IsbnId isbn -> "isbn:" <> isbn + PodcastGuidId guid -> "podcast:guid:" <> guid + PodcastItemGuidId guid -> "podcast:item:guid:" <> guid + PodcastPublisherGuidId guid -> "podcast:publisher:guid:" <> guid + IsanId isan -> "isan:" <> isan + DoiId doi -> "doi:" <> doi + +-- | FromJSON instance for ExternalId +instance FromJSON ExternalId where + parseJSON = withText "ExternalId" $ \t -> + case parseExternalId t of + Just eid -> return eid + Nothing -> fail $ "Invalid external identifier: " <> T.unpack t + +-- | ToJSON instance for ExternalId +instance ToJSON ExternalId where + toEncoding = text . externalIdToText + toJSON = String . externalIdToText \ No newline at end of file diff --git a/src/Presentation/RelayMgmtUI.hs b/src/Presentation/RelayMgmtUI.hs index 25e4750..5de1672 100644 --- a/src/Presentation/RelayMgmtUI.hs +++ b/src/Presentation/RelayMgmtUI.hs @@ -123,6 +123,7 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action dmRelayPool <- newFactoryPool (newObject dmRelayClass) generalRelayPool <- newFactoryPool (newObject relayClass) + tempRelayPool <- newFactoryPool (newObject relayClass) contextClass <- newClass [ defPropertySigRO' "dmRelays" changeKey $ \obj -> do @@ -152,6 +153,28 @@ runRelayMgmtUI action = interpret handleRelayMgmtUI action Just (rs', _) -> map getUri rs' mapM (getPoolObject generalRelayPool) rs, + defPropertySigRO' "tempRelays" changeKey $ \obj -> do + runE $ modify @EffectfulQMLState $ \s -> s { + uiRefs = (uiRefs s) { tempRelaysObjRef = Just obj } + } + poolState <- runE $ get @RelayPoolState + appState <- runE $ get @AppState + + let activeURIs = Map.keys (activeConnections poolState) + + case keyPair appState of + Nothing -> return [] + Just kp -> do + let pk = keyPairToPubKeyXO kp + (dmRelaysWithStatus, _) <- runE $ getDMRelays pk + let dmURIs = map (getUri . fst) dmRelaysWithStatus + let generalURIs = case Map.lookup pk (generalRelays poolState) of + Nothing -> [] + Just (rs, _) -> map getUri rs + + let tempURIs = filter (\uri -> uri `notElem` dmURIs && uri `notElem` generalURIs) activeURIs + mapM (getPoolObject tempRelayPool) tempURIs, + defMethod' "addDMRelay" $ \_ input -> runE $ do kp <- getKeyPair addDMRelay (keyPairToPubKeyXO kp) input, diff --git a/src/RelayMgmt.hs b/src/RelayMgmt.hs index b42b1c8..ba3be56 100644 --- a/src/RelayMgmt.hs +++ b/src/RelayMgmt.hs @@ -3,14 +3,11 @@ 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 KeyMgmt (AccountId(..), KeyMgmt, updateRelays) @@ -189,25 +186,6 @@ runRelayMgmt = interpret $ \_ -> \case return (relaysWithStatus, timestamp) --- | 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 diff --git a/src/TimeFormatter.hs b/src/TimeFormatter.hs index 388c10b..9ff5c49 100644 --- a/src/TimeFormatter.hs +++ b/src/TimeFormatter.hs @@ -1,4 +1,4 @@ -module TimeFormatter (formatDateTime) where +module TimeFormatter (Language(..), formatDateTime) where import Data.Text (Text) import Data.Text qualified as T @@ -16,7 +16,20 @@ formatUTCTime :: String -> UTCTime -> Text formatUTCTime format utcTime = T.pack $ formatTime defaultTimeLocale format utcTime -- Helper function to format time -formatDateTime :: Language -> Int -> Text -formatDateTime English = formatUTCTime "%H:%M:%S %Y-%m-%d" . intToUTCTime -formatDateTime German = formatUTCTime "%H:%M:%S %d.%m.%Y" . intToUTCTime -formatDateTime Spanish = formatUTCTime "%H:%M:%S %d/%m/%Y" . intToUTCTime +formatDateTime :: Language -> Int -> Int -> Text +formatDateTime lang currentTimestamp messageTimestamp = + let secondsInDay = 24 * 60 * 60 + diffInDays = (currentTimestamp - messageTimestamp) `div` secondsInDay + isToday = diffInDays == 0 + in case lang of + English -> if isToday + then formatUTCTime "%I:%M %p" (intToUTCTime messageTimestamp) + else formatUTCTime "%b %d, %I:%M %p" (intToUTCTime messageTimestamp) + + German -> if isToday + then formatUTCTime "%H:%M" (intToUTCTime messageTimestamp) + else formatUTCTime "%d.%m., %H:%M" (intToUTCTime messageTimestamp) + + Spanish -> if isToday + then formatUTCTime "%H:%M" (intToUTCTime messageTimestamp) + else formatUTCTime "%d/%m, %H:%M" (intToUTCTime messageTimestamp) diff --git a/src/Types.hs b/src/Types.hs index 8a2f30a..776e761 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -14,9 +14,11 @@ import Nostr.Types (Event, EventId, Filter, Profile, Relay, RelayURI, Request, S data UIUpdates = UIUpdates { profilesChanged :: Bool , followsChanged :: Bool - , chatsChanged :: Bool + , postsChanged :: Bool + , privateMessagesChanged :: Bool , dmRelaysChanged :: Bool , generalRelaysChanged :: Bool + , tempRelaysChanged :: Bool , publishStatusChanged :: Bool , noticesChanged :: Bool } deriving (Eq, Show) @@ -26,9 +28,11 @@ instance Semigroup UIUpdates where a <> b = UIUpdates { profilesChanged = profilesChanged a || profilesChanged b , followsChanged = followsChanged a || followsChanged b - , chatsChanged = chatsChanged a || chatsChanged b + , postsChanged = postsChanged a || postsChanged b + , privateMessagesChanged = privateMessagesChanged a || privateMessagesChanged b , dmRelaysChanged = dmRelaysChanged a || dmRelaysChanged b , generalRelaysChanged = generalRelaysChanged a || generalRelaysChanged b + , tempRelaysChanged = tempRelaysChanged a || tempRelaysChanged b , publishStatusChanged = publishStatusChanged a || publishStatusChanged b , noticesChanged = noticesChanged a || noticesChanged b } @@ -40,7 +44,7 @@ instance Monoid UIUpdates where -- | Empty UI updates. emptyUpdates :: UIUpdates -emptyUpdates = UIUpdates False False False False False False False +emptyUpdates = UIUpdates False False False False False False False False False -- | Status of a publish operation @@ -136,6 +140,27 @@ data ChatMessage = ChatMessage } deriving (Show) +-- | Type of note +data NoteType + = ShortTextNote + | Repost EventId -- kind 6, references original note + | QuoteRepost EventId -- kind 1 with q tag, includes quoted event and additional content + | Comment { + rootScope :: EventId, -- root event being commented on + rootKind :: Int, -- kind of root event + parentId :: EventId, -- immediate parent (same as root for top-level comments) + parentKind :: Int -- kind of parent + } + deriving (Show, Eq) + + +-- | Simplified note reference that proxies most data through events map +data Post = Post + { postId :: EventId -- ID of this post + , postType :: NoteType -- Type of post and its references + } deriving (Show) + + -- | Application state. data AppState = AppState { keyPair :: Maybe KeyPair @@ -143,12 +168,13 @@ data AppState = AppState -- Relay management , activeConnectionsCount :: Int -- Data storage - , events :: Map EventId (Event, [Relay]) - , chats :: Map [PubKeyXO] [ChatMessage] + , posts :: Map PubKeyXO [Post] + , events :: Map EventId (Event, [RelayURI]) + , chats :: Map PubKeyXO [ChatMessage] , profiles :: Map PubKeyXO (Profile, Int) , follows :: Map PubKeyXO [Follow] -- UI state - , currentChatRecipient :: (Maybe [PubKeyXO], Maybe SubscriptionId) + , currentContact :: (Maybe PubKeyXO, Maybe SubscriptionId) , currentProfile :: Maybe PubKeyXO } @@ -156,9 +182,11 @@ data AppState = AppState data UIReferences = UIReferences { profileObjRef :: Maybe (ObjRef ()) , followsObjRef :: Maybe (ObjRef ()) - , chatObjRef :: Maybe (ObjRef ()) + , postsObjRef :: Maybe (ObjRef ()) + , privateMessagesObjRef :: Maybe (ObjRef ()) , dmRelaysObjRef :: Maybe (ObjRef ()) , generalRelaysObjRef :: Maybe (ObjRef ()) + , tempRelaysObjRef :: Maybe (ObjRef ()) } @@ -177,9 +205,10 @@ initialState = AppState , currentScreen = KeyMgmt , activeConnectionsCount = 0 , events = Map.empty + , posts = Map.empty , chats = Map.empty , profiles = Map.empty , follows = Map.empty - , currentChatRecipient = (Nothing, Nothing) + , currentContact = (Nothing, Nothing) , currentProfile = Nothing } diff --git a/src/UI.hs b/src/UI.hs index 2a6af21..72d4b07 100644 --- a/src/UI.hs +++ b/src/UI.hs @@ -6,7 +6,7 @@ module UI where import Data.Aeson (decode, encode) import Data.ByteString.Lazy qualified as BSL -import Data.List (find, sortOn) +import Data.List (find) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(..)) @@ -29,8 +29,8 @@ import Nostr.Types (EventId(..), Profile(..), emptyProfile, getUri) import Nostr.Util import Presentation.KeyMgmtUI qualified as KeyMgmtUI import Presentation.RelayMgmtUI qualified as RelayMgmtUI -import Futr ( Futr, FutrEff, LoginStatusChanged, login, logout, followProfile, openChat, - search, sendMessage, setCurrentProfile, unfollowProfile ) +import Futr hiding (Comment, QuoteRepost, Repost) +import TimeFormatter import Types -- | Key Management Effect for creating QML UI. @@ -105,43 +105,196 @@ runUI = interpret $ \_ -> \case st <- runE $ get @AppState let followList' = follows st let userPubKey = keyPairToPubKeyXO <$> keyPair st - let followData = userPubKey >>= \upk -> Map.lookup upk followList' >>= find (\f -> pubkey f == pubKeyXO) + let followData = case userPubKey of + Just upk | upk == pubKeyXO -> + Just Follow { pubkey = pubKeyXO, followRelay = Nothing, petName = Nothing } + Just upk -> + Map.lookup upk followList' >>= find (\f -> pubkey f == pubKeyXO) + Nothing -> Nothing return $ accessor st followData followClass <- newClass [ - followProp "pubkey" $ \_ followMaybe -> - maybe "" (pubKeyXOToBech32 . pubkey) followMaybe, - followProp "relay" $ \_ followMaybe -> - maybe "" (\f -> maybe "" getUri (followRelay f)) followMaybe, - followProp "petname" $ \_ followMaybe -> - maybe "" (fromMaybe "" . petName) followMaybe, - followProp "displayName" $ \st followMaybe -> - case followMaybe of - Just follow -> - let (profile', _) = Map.findWithDefault (emptyProfile, 0) (pubkey follow) (profiles st) - in fromMaybe "" (displayName profile') - Nothing -> "", - followProp "name" $ \st followMaybe -> - case followMaybe of - Just follow -> - let (profile', _) = Map.findWithDefault (emptyProfile, 0) (pubkey follow) (profiles st) - in fromMaybe "" (name profile') - Nothing -> "", - followProp "picture" $ \st followMaybe -> - case followMaybe of - Just follow -> - let (profile', _) = Map.findWithDefault (emptyProfile, 0) (pubkey follow) (profiles st) - in fromMaybe "" (picture profile') - Nothing -> "" + followProp "pubkey" $ \_ followMaybe -> maybe "" (pubKeyXOToBech32 . pubkey) followMaybe, + followProp "relay" $ \_ followMaybe -> maybe "" (\f -> maybe "" getUri (followRelay f)) followMaybe, + followProp "petname" $ \_ followMaybe -> maybe "" (fromMaybe "" . petName) followMaybe, + followProp "displayName" $ \st followMaybe -> case followMaybe of + Just follow -> + let (profile', _) = Map.findWithDefault (emptyProfile, 0) (pubkey follow) (profiles st) + in fromMaybe "" (displayName profile') + Nothing -> "", + followProp "name" $ \st followMaybe -> case followMaybe of + Just follow -> + let (profile', _) = Map.findWithDefault (emptyProfile, 0) (pubkey follow) (profiles st) + in fromMaybe "" (name profile') + Nothing -> "", + followProp "picture" $ \st followMaybe -> case followMaybe of + Just follow -> + let (profile', _) = Map.findWithDefault (emptyProfile, 0) (pubkey follow) (profiles st) + in fromMaybe "" (picture profile') + Nothing -> "" ] followPool <- newFactoryPool (newObject followClass) + postClass <- newClass [ + defPropertySigRO' "id" changeKey' $ \obj -> do + let eid = fromObjRef obj :: EventId + return $ pack $ show eid, + + defPropertySigRO' "postType" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Nothing -> return Nothing + Just msg -> return $ Just $ pack $ case postType msg of + ShortTextNote -> "short_text_note" + Repost _ -> "repost" + QuoteRepost _ -> "quote_repost" + Comment{rootScope=_} -> "comment", + + defPropertySigRO' "referencedEventId" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Just msg -> return $ Just $ pack $ case postType msg of + Repost ref -> show ref + QuoteRepost ref -> show ref + Comment{rootScope=ref} -> show ref + _ -> "" + Nothing -> return Nothing, + + defPropertySigRO' "content" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Just msg -> runE $ getPostContent msg + Nothing -> return Nothing + _ -> return Nothing, + + defPropertySigRO' "timestamp" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Just msg -> do + ts <- runE $ getPostCreatedAt msg + case ts of + Just ts' -> do + now <- runE getCurrentTime + return $ Just $ formatDateTime English now ts' + Nothing -> return Nothing + Nothing -> return Nothing, + + defPropertySigRO' "referencedContent" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Just msg -> case postType msg of + Repost ref -> runE $ getReferencedContent ref + QuoteRepost ref -> runE $ getReferencedContent ref + Comment{rootScope=ref} -> runE $ getReferencedContent ref + _ -> return Nothing + Nothing -> return Nothing, + + defPropertySigRO' "referencedAuthorPubkey" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Just msg -> case postType msg of + Repost ref -> do + authorMaybe <- runE $ getReferencedAuthor ref + return $ fmap pubKeyXOToBech32 authorMaybe + QuoteRepost ref -> do + authorMaybe <- runE $ getReferencedAuthor ref + return $ fmap pubKeyXOToBech32 authorMaybe + Comment{rootScope=ref} -> do + authorMaybe <- runE $ getReferencedAuthor ref + return $ fmap pubKeyXOToBech32 authorMaybe + _ -> return Nothing + Nothing -> return Nothing, + + defPropertySigRO' "referencedAuthorName" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Nothing -> return Nothing + Just msg -> case postType msg of + Repost ref -> runE $ getReferencedAuthorName ref + QuoteRepost ref -> runE $ getReferencedAuthorName ref + Comment{rootScope=ref} -> runE $ getReferencedAuthorName ref + _ -> return Nothing, + + defPropertySigRO' "referencedAuthorPicture" changeKey' $ \obj -> do + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Nothing -> return Nothing + Just msg -> case postType msg of + Repost ref -> runE $ getReferencedAuthorPicture ref + QuoteRepost ref -> runE $ getReferencedAuthorPicture ref + Comment{rootScope=ref} -> runE $ getReferencedAuthorPicture ref + _ -> return Nothing, + + defPropertySigRO' "referencedCreatedAt" changeKey' $ \obj -> do + let getFormattedTime ref = do + tsM <- runE $ getReferencedCreatedAt ref + case tsM of + Just ts -> do + now <- runE getCurrentTime + return $ Just $ formatDateTime English now ts + Nothing -> return Nothing + st <- runE $ get @AppState + let eid = fromObjRef obj :: EventId + case currentContact st of + (Nothing, _) -> return Nothing + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + case find (\msg -> postId msg == eid) notes of + Nothing -> return Nothing + Just msg -> case postType msg of + Repost ref -> getFormattedTime ref + QuoteRepost ref -> getFormattedTime ref + Comment{rootScope=ref} -> getFormattedTime ref + _ -> return Nothing + ] + + postsPool <- newFactoryPool (newObject postClass) + chatClass <- newClass [ defPropertySigRO' "content" changeKey' $ \obj -> do st <- runE $ get @AppState let eid = fromObjRef obj :: EventId - let currentRecipient = currentChatRecipient st + let currentRecipient = currentContact st case currentRecipient of (Just recipient, _) -> do let chatMessages = Map.findWithDefault [] recipient (chats st) @@ -154,7 +307,7 @@ runUI = interpret $ \_ -> \case st <- runE $ get @AppState let eid = fromObjRef obj :: EventId let pk = keyPairToPubKeyXO <$> keyPair st - let currentRecipient = currentChatRecipient st + let currentRecipient = currentContact st case (pk, currentRecipient) of (Just userPk, (Just recipient, _)) -> do let chatMessages = Map.findWithDefault [] recipient (chats st) @@ -166,8 +319,7 @@ runUI = interpret $ \_ -> \case defPropertySigRO' "timestamp" changeKey' $ \obj -> do st <- runE $ get @AppState let eid = fromObjRef obj :: EventId - let currentRecipient = currentChatRecipient st - case currentRecipient of + case currentContact st of (Just recipient, _) -> do let chatMessages = Map.findWithDefault [] recipient (chats st) case find (\msg -> chatMessageId msg == eid) chatMessages of @@ -226,7 +378,7 @@ runUI = interpret $ \_ -> \case res <- search obj input return $ TE.decodeUtf8 $ BSL.toStrict $ encode res, - defMethod' "setCurrentProfile" $ \_ npub -> runE $ setCurrentProfile npub, + defMethod' "setCurrentProfile" $ \_ npub' -> runE $ setCurrentProfile npub', defMethod' "saveProfile" $ \_ input -> do let profile = maybe (error "Invalid profile JSON") id $ decode (BSL.fromStrict $ TE.encodeUtf8 input) :: Profile @@ -240,29 +392,37 @@ runUI = interpret $ \_ -> \case runE $ logInfo "Profile successfully saved and sent to relay pool" Nothing -> runE $ logWarning "Failed to sign profile update event", - defPropertySigRO' "follows" changeKey' $ \obj -> do + defPropertySigRO' "followList" 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 (follows st) - objs <- mapM (getPoolObject followPool) (map pubkey userFollows) + let selfFollow = Follow { pubkey = userPubKey, followRelay = Nothing, petName = Nothing } + objs <- mapM (getPoolObject followPool) (map pubkey (selfFollow : userFollows)) return objs Nothing -> return [], - defPropertySigRO' "messages" changeKey' $ \obj -> do - runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { chatObjRef = Just obj } } + defPropertySigRO' "posts" changeKey' $ \obj -> do + runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { postsObjRef = Just obj } } st <- runE $ get @AppState - case currentChatRecipient st of + case currentContact st of + (Just recipient, _) -> do + let notes = Map.findWithDefault [] recipient (posts st) + objs <- mapM (getPoolObject postsPool) (map postId notes) + return objs + _ -> do return [], + + defPropertySigRO' "privateMessages" changeKey' $ \obj -> do + runE $ modify @EffectfulQMLState $ \s -> s { uiRefs = (uiRefs s) { privateMessagesObjRef = Just obj } } + st <- runE $ get @AppState + case currentContact 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) + objs <- mapM (getPoolObject chatPool) (map chatMessageId chatMessages) return objs - _ -> do - runE $ logDebug $ "No current chat recipient" - return [], + _ -> do return [], defMethod' "follow" $ \_ npubText -> runE $ followProfile npubText, @@ -272,7 +432,24 @@ runUI = interpret $ \_ -> \case let pubKeyXO = maybe (error "Invalid bech32 public key") id $ bech32ToPubKeyXO npubText openChat pubKeyXO, - defMethod' "sendMessage" $ \_ input -> runE $ sendMessage input + defMethod' "sendMessage" $ \_ input -> runE $ sendMessage input, -- NIP-17 private direct message + + defMethod' "sendShortTextNote" $ \_ input -> runE $ sendShortTextNote input, -- NIP-01 short text note + + defMethod' "repost" $ \_ eid -> runE $ do -- NIP-18 repost + let unquoted = read (unpack eid) :: String + let eid' = read unquoted :: EventId + repost eid', + + defMethod' "quoteRepost" $ \_ eid quote -> runE $ do -- NIP-18 quote repost + let unquoted = read (unpack eid) :: String + let eid' = read unquoted :: EventId + quoteRepost eid' quote, + + defMethod' "comment" $ \_ eid input -> runE $ do -- NIP-22 comment + let unquoted = read (unpack eid) :: String + let eid' = read unquoted :: EventId + comment eid' input ] rootObj <- newObject rootClass ()