From 2049cc83b60dca41f636190f87cb1f21707f3530 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 14 Nov 2018 01:28:47 -0500 Subject: MUC: It works. --- Presence/Chat.hs | 26 +++++------ Presence/LocalChat.hs | 4 +- Presence/MUC.hs | 4 +- Presence/Stanza/Build.hs | 22 +++++++--- Presence/Stanza/Parse.hs | 9 +++- Presence/Stanza/Types.hs | 55 +++++++++++++++++++++++ Presence/XMPPServer.hs | 111 +++++++++++++++++++++++++++++++++++++++++++---- 7 files changed, 198 insertions(+), 33 deletions(-) (limited to 'Presence') diff --git a/Presence/Chat.hs b/Presence/Chat.hs index 172c5242..b7343b5a 100644 --- a/Presence/Chat.hs +++ b/Presence/Chat.hs @@ -76,6 +76,7 @@ newtype RoomHandle = RH (TVar (Maybe ChatTransaction)) data JoinedRoom k = JoinedRoom { joinedRoom :: Room k + , joinedNick :: Text , roomHandle :: RoomHandle , roomTransactions :: TChan ChatTransaction } @@ -110,29 +111,28 @@ joinRoom k room jid nick = do v <- newTVar (Just $ ChatTransaction no jid nick [Join]) modifyTVar' (roomDesiredTransaction room) $ Map.insert k v c <- dupTChan (roomChan room) - return $ JoinedRoom room (RH v) c + return $ JoinedRoom room nick (RH v) c -partRoom :: JoinedRoom k -> Maybe Text -> Text -> STM () -partRoom (JoinedRoom room (RH v) c) jid nick = do +partRoom :: JoinedRoom k -> Maybe Text -> STM () +partRoom (JoinedRoom room nick (RH v) c) jid = do writeTVar v Nothing -- Cancel pending chat. - sendChat (JoinedRoom room (RH v) c) jid nick [Part] + sendChat (JoinedRoom room nick (RH v) c) jid [Part] return () -sendChat :: JoinedRoom k -> Maybe Text -> Text -> [ChatEvent] -> STM Bool -sendChat (JoinedRoom room (RH v) _) jid nick chat = do +sendChat :: JoinedRoom k -> Maybe Text -> [ChatEvent] -> STM Bool +sendChat (JoinedRoom room nick (RH v) _) jid chat = do mpending <- readTVar v + no <- readTVar $ roomFutureSeqNo room case mpending of - Nothing -> do - no <- readTVar $ roomFutureSeqNo room + Just (ChatTransaction no' _ _ _) | no' >= no -> return False + _ -> do writeTVar v (Just $ ChatTransaction no jid nick chat) return True - Just pending -> do - return False -- | Blocks until a transaction occurs. Optionally, a failed transaction will -- be automatically renewed. readRoom :: Ord k => k -> JoinedRoom k -> STM (Bool, ChatTransaction) -readRoom k (JoinedRoom room (RH v) c) = do +readRoom k (JoinedRoom room _ (RH v) c) = do mpending <- readTVar v final <- readTChan c case mpending of @@ -198,7 +198,7 @@ roomCommit room k t = do modifyTVar' (roomFutureSeqNo room) succ writeTChan (roomChan room) t v <- validateTransaction room k t - trace ("roomCommit " ++ show v) $ return () + trace ("roomCommit " ++ show v ++ " " ++ show t) $ return () case v of Valid Outside Inside -> do modifyTVar' (roomMembers room) $ Map.insert (chatSender t) PerMember @@ -209,7 +209,7 @@ roomCommit room k t = do modifyTVar' (roomMembers room) $ Map.delete (chatSender t) fin Valid _ _ -> fin - _ -> return () + bad -> trace ("validateTransaction: " ++ show bad) $ return () roomPending :: Ord k => Room k -> STM (Map k ChatTransaction) roomPending room = do diff --git a/Presence/LocalChat.hs b/Presence/LocalChat.hs index 39195fc9..eab54a03 100644 --- a/Presence/LocalChat.hs +++ b/Presence/LocalChat.hs @@ -47,10 +47,10 @@ chatevents rsvar = do ps <- roomPending r trace ("roomPending " ++ show ps) $ return () case Map.toList ps of - (k,t):_ -> do + (k,t):ts -> do roomCommit r k t return $ do - dput XJabber $ "fuck " ++ show (k,t) + dput XJabber $ "committed " ++ show (length ts,k,t) _ -> retry return $ foldl1 (>>) ios diff --git a/Presence/MUC.hs b/Presence/MUC.hs index 76c53391..639e834b 100644 --- a/Presence/MUC.hs +++ b/Presence/MUC.hs @@ -42,8 +42,8 @@ mucReservedNick muc rkey = atomically $ do Nothing -> return Nothing Just r -> return $ Just $ \jid -> atomically $ roomReservedNick r jid -mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> IO (JoinedRoom ClientAddress) -mucJoinRoom muc jid nick rkey k = atomically $ do +mucJoinRoom :: MUC -> Text{-JID-} -> Text{-nick-} -> Text{-room-} -> ClientAddress -> STM (JoinedRoom ClientAddress) +mucJoinRoom muc jid nick rkey k = do mr <- Map.lookup rkey <$> readTVar (mucRooms muc) case mr of Nothing -> do diff --git a/Presence/Stanza/Build.hs b/Presence/Stanza/Build.hs index e02684f5..16552428 100644 --- a/Presence/Stanza/Build.hs +++ b/Presence/Stanza/Build.hs @@ -19,24 +19,34 @@ import LockedChan import Stanza.Types makeMessage :: Text -> Text -> Text -> Text -> IO Stanza -makeMessage namespace from to bod = +makeMessage namespace from to bod = makeMessageEx namespace from to NormalMsg bod + +makeMessageEx :: Text -> Text -> Text -> MessageType -> Text -> IO Stanza +makeMessageEx namespace from to msgtyp bod = stanzaFromList typ $ [ EventBeginElement (mkname namespace "message") - [ attr "from" from - , attr "to" to - ] + $ addMessageType msgtyp + [ attr "from" from + , attr "to" to + ] , EventBeginElement (mkname namespace "body") [] , EventContent (ContentText bod) , EventEndElement (mkname namespace "body") , EventEndElement (mkname namespace "message") ] where - typ = Message { msgThread = Nothing + typ = Message { msgThread = Nothing , msgLangMap = [("", lsm)] + , msgType = msgtyp } lsm = LangSpecificMessage - { msgBody = Just bod + { msgBody = Just bod , msgSubject = Nothing } +addMessageType ChatMsg attrs = ("type",[ContentText "chat"]) : attrs +addMessageType GroupChatMsg attrs = ("type",[ContentText "groupchat"]) : attrs +addMessageType HeadlineMsg attrs = ("type",[ContentText "headline"]) : attrs +addMessageType _ attrs = attrs + makeInformSubscription :: Text -> Text -> Text -> Bool -> IO Stanza makeInformSubscription namespace from to approved = stanzaFromList (PresenceInformSubscription approved) diff --git a/Presence/Stanza/Parse.hs b/Presence/Stanza/Parse.hs index b025f418..58bf7c51 100644 --- a/Presence/Stanza/Parse.hs +++ b/Presence/Stanza/Parse.hs @@ -227,9 +227,16 @@ parseMessage ns stanza = do , Map.empty ) return Message { msgLangMap = Map.toList langmap, - msgThread = if msgThreadContent th/="" then Just th else Nothing + msgThread = if msgThreadContent th/="" then Just th else Nothing, + msgType = parseMessageType $ lookupAttrib "type" (tagAttrs stanza) } +parseMessageType :: Maybe Text -> MessageType +parseMessageType (Just "chat") = ChatMsg +parseMessageType (Just "groupchat") = GroupChatMsg +parseMessageType (Just "headline") = HeadlineMsg +parseMessageType _ = NormalMsg + findErrorTag :: Monad m => Text -> NestingXML o m (Maybe StanzaError) findErrorTag ns = do x <- nextElement diff --git a/Presence/Stanza/Types.hs b/Presence/Stanza/Types.hs index 6c5b8867..7275c8ab 100644 --- a/Presence/Stanza/Types.hs +++ b/Presence/Stanza/Types.hs @@ -70,6 +70,7 @@ data StanzaType | PresenceRequestSubscription Bool | Message { msgThread :: Maybe MessageThread , msgLangMap :: [(Lang,LangSpecificMessage)] + , msgType :: MessageType } | NotifyClientVersion { versionName :: Text , versionVersion :: Text } @@ -77,6 +78,60 @@ data StanzaType | InternalCacheId Text deriving (Show,Eq) +data MessageType + = NormalMsg -- ^ The message is a standalone message that is sent outside + -- the context of a one-to-one conversation or groupchat, and + -- to which it is expected that the recipient will reply. + -- Typically a receiving client will present a message of type + -- "normal" in an interface that enables the recipient to + -- reply, but without a conversation history. The default + -- value of the 'type' attribute is "normal". + + | ChatMsg -- ^ The message is sent in the context of a one-to-one chat + -- session. Typically an interactive client will present a + -- message of type "chat" in an interface that enables one-to-one + -- chat between the two parties, including an appropriate + -- conversation history. Detailed recommendations regarding + -- one-to-one chat sessions are provided under Section 5.1. + + | GroupChatMsg -- ^ The message is sent in the context of a multi-user chat + -- environment (similar to that of [IRC]). Typically a + -- receiving client will present a message of type + -- "groupchat" in an interface that enables many-to-many + -- chat between the parties, including a roster of parties + -- in the chatroom and an appropriate conversation history. + -- For detailed information about XMPP-based groupchat, + -- refer to [XEP‑0045]. + + | HeadlineMsg -- ^ The message provides an alert, a notification, or other + -- transient information to which no reply is expected (e.g., + -- news headlines, sports updates, near-real-time market + -- data, or syndicated content). Because no reply to the + -- message is expected, typically a receiving client will + -- present a message of type "headline" in an interface that + -- appropriately differentiates the message from standalone + -- messages, chat messages, and groupchat messages (e.g., by + -- not providing the recipient with the ability to reply). If + -- the 'to' address is the bare JID, the receiving server + -- SHOULD deliver the message to all of the recipient's + -- available resources with non-negative presence priority + -- and MUST deliver the message to at least one of those + -- resources; if the 'to' address is a full JID and there is + -- a matching resource, the server MUST deliver the message + -- to that resource; otherwise the server MUST either + -- silently ignore the message or return an error (see + -- Section 8). + + -- | ErrorMsg -- The message is generated by an entity that experiences an + -- error when processing a message received from another entity (for + -- details regarding stanza error syntax, refer to [XMPP‑CORE]). A client + -- that receives a message of type "error" SHOULD present an appropriate + -- interface informing the original sender regarding the nature of the + -- error. + + deriving (Show,Read,Ord,Eq,Enum) + + data RosterEventType = RequestedSubscription | NewBuddy -- preceded by PresenceInformSubscription True diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index e44ae37b..d26e8c03 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -1364,6 +1364,28 @@ monitor sv params xmpp = do , EventEndElement "{http://jabber.org/protocol/muc#user}x" ] ioWriteChan replyto stanza + Part -> do + stanza <- makePresenceStanzaEx "jabber:client" (Just $ roomjid muckey me rkey cnick) Offline + $ [ EventBeginElement "{http://jabber.org/protocol/muc#user}x" [] ] + ++ (do guard mine + [ EventBeginElement "{http://jabber.org/protocol/muc#user}status" + [ ("code",[ContentText "110"]) -- self-presence code. + ] + , EventEndElement "{http://jabber.org/protocol/muc#user}status" ]) + ++ [ EventEndElement "{http://jabber.org/protocol/muc#user}x" ] + ioWriteChan replyto stanza + when mine $ atomically $ do + jrs <- readTVar joined_rooms + let m = Map.findWithDefault Map.empty k jrs + m' = Map.delete (rkey,muckey) m + jrs' = if Map.null m' then Map.delete k jrs + else Map.insert k m' jrs + writeTVar joined_rooms jrs' + Talk talk -> do + them <- xmppTellClientHisName xmpp k + stanza <- makeMessageEx "jabber:client" (roomjid muckey me rkey cnick) them GroupChatMsg talk + ioWriteChan replyto stanza + return () _ -> return () ] action @@ -1409,7 +1431,7 @@ data ServiceMatch a | TopLevelService -- ^ This server's exact hostname. -lookupService :: Text -> Map.Map Text a -> Text -> (ServiceMatch a) +lookupService :: Text {- ^ hostname -} -> Map.Map Text a {- ^ service map -} -> Text {- ^ JID -} -> (ServiceMatch a) lookupService me mucs to = case Text.toLower to of nm | nm == Text.toLower me -> TopLevelService @@ -1432,7 +1454,9 @@ applyStanza :: Server PeerAddress ConnectionData releaseKey Event -> StanzaWrap (LockedChan Event) -> IO () -applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of +applyStanza sv joined_rooms quitVar xmpp stanza = do + dput XJabber $ "applyStanza: " ++ show (stanzaType stanza) + case stanzaOrigin stanza of ClientOrigin k replyto -> case stanzaType stanza of RequestResource clientsNameForMe wanted -> do @@ -1479,8 +1503,7 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of PresenceStatus {} -> do let mucs = xmppGroupChat xmpp me <- xmppTellMyNameToClient xmpp k - if | Available <- presenceShow (stanzaType stanza) - , Just to <- stanzaTo stanza + if | Just to <- stanzaTo stanza , (Just room,h,mnick) <- splitJID to , let roomjid = unsplitJID ((Just room,h,Nothing)) , Service (Just _) mucname muc <- lookupService me mucs roomjid @@ -1490,13 +1513,34 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of reply <- makeErrorStanza' stanza JidMalformed [ ("by", [ContentText roomjid]) ] sendReply quitVar (Error JidMalformed (head reply)) reply replyto - Just nick -> do - jid <- xmppTellClientHisName xmpp k - r <- mucJoinRoom muc jid nick room k -- stanza - atomically $ do + Just nick -> case presenceShow (stanzaType stanza) of + Available -> do + jid <- xmppTellClientHisName xmpp k + join $ atomically $ do jrs <- readTVar joined_rooms let m = Map.findWithDefault Map.empty k jrs - writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs + case Map.lookup (room,mucname) m of + Nothing -> do r <- mucJoinRoom muc jid nick room k -- stanza + jrs <- readTVar joined_rooms + let m = Map.findWithDefault Map.empty k jrs + writeTVar joined_rooms $ Map.insert k (Map.insert (room,mucname) (replyto,r) m) jrs + return $ return () + Just r -> return $ dput XJabber "MUC: already joined." + Offline -> do + jid <- xmppTellClientHisName xmpp k + atomically $ do + jrs <- readTVar joined_rooms + let m = Map.findWithDefault Map.empty k jrs + case Map.lookup (room,mucname) m of + Just (_,r) -> do + partRoom r (Just jid) -- joinedNick r == nick + {- + let m' = Map.delete (room,mucname) m + jrs' = if Map.null m' then Map.delete k jrs + else Map.insert k m' jrs + writeTVar joined_rooms jrs' + -} + _ -> return () | otherwise -> do -- Handle presence stanza that is not a chatroom join. xmppInformClientPresence xmpp k stanza @@ -1541,6 +1585,24 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of let reply = makeNodeInfo (stanzaId stanza) "x-roomuser-item" (room <> "@" <> a <> "." <> me) (stanzaFrom stanza) n return (Info, reply) + (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#traffic" <- mnode + -> do + dput XJabber $ "TODO: 18.1.1 Allowable Traffic" + reply <- makeErrorStanza' stanza FeatureNotImplemented + [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] + return (Error FeatureNotImplemented (head reply), reply) + (Service (Just room) a muc) | Just "http://jabber.org/protocol/muc#rooms" <- mnode + -> do + dput XJabber $ "TODO: 6.7 Discovering Client Support for MUC" + reply <- makeErrorStanza' stanza FeatureNotImplemented + [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] + return (Error FeatureNotImplemented (head reply), reply) + (Service (Just room) a muc) | Just nodename <- mnode + -> do + dput XJabber $ "Uknown info node: " ++ Text.unpack nodename + reply <- makeErrorStanza' stanza FeatureNotImplemented + [ ("by", [ContentText (room <> "@" <> a <> "." <> me)]) ] + return (Error FeatureNotImplemented (head reply), reply) TopLevelService -> case mnode of Just _ -> unavail @@ -1579,6 +1641,36 @@ applyStanza sv joined_rooms quitVar xmpp stanza = case stanzaOrigin stanza of me <- xmppTellMyNameToClient xmpp k let reply = iq_service_unavailable (stanzaId stanza) me query sendReply quitVar (Error ServiceUnavailable (head reply)) reply replyto + Message { msgType = GroupChatMsg } -> do + let mucs = xmppGroupChat xmpp + me <- xmppTellMyNameToClient xmpp k + if | Just to <- stanzaTo stanza + , (Just room,h,mnick) <- splitJID to + , let roomjid = unsplitJID ((Just room,h,Nothing)) + , Service (Just _) mucname muc <- lookupService me mucs roomjid + -> case mnick of + Nothing -> do + -- Send message. + jid <- xmppTellClientHisName xmpp k -- This should match stanzaFrom + join $ atomically $ do + jrs <- readTVar joined_rooms + let m = Map.findWithDefault Map.empty k jrs + case Map.lookup (room,mucname) m of + Just (_,r) -> do + let RH v = roomHandle r + oldt <- readTVar v + expected <- readTVar (roomFutureSeqNo $ joinedRoom r) + b <- sendChat r (Just jid) $ do + (_,msg) <- msgLangMap (stanzaType stanza) + talk <- maybeToList $ msgBody msg + [ Talk talk ] + return $ dput XJabber $ "sendChat: " ++ show (b,expected,oldt,msgLangMap (stanzaType stanza)) + _ -> return $ dput XJabber $ "uknown room" ++ show (room,mucname) + Just nick -> do + -- Private message. TODO + dput XJabber $ "TODO: Private messasge. " ++ show nick + + | otherwise -> dput XJabber $ "Failed groupchat parse. to=" ++ show (stanzaTo stanza) Message {} -> do -- wlog $ "LANGMAP "++show (stanzaId stanza, msgLangMap (stanzaType stanza)) maybe (return ()) (flip cacheMessageId replyto) $ do @@ -1615,6 +1707,7 @@ forwardStanza quitVar xmpp stanza = do -- let newStream = greet'' "jabber:client" "blackbird" -- sendReply quitVar Error newStream replyto case stanzaType stanza of + Message { msgType = GroupChatMsg } -> return () -- Group chat handled elsewhere. Message {} -> do case stanzaOrigin stanza of LocalPeer {} -> return () -- cgit v1.2.3